pax_global_header00006660000000000000000000000064150757467570014541gustar00rootroot0000000000000052 comment=67a47ac4fc2744fe0a95ad488c05e55e57f38ead guile-hoot-0.7.0/000077500000000000000000000000001507574675700136215ustar00rootroot00000000000000guile-hoot-0.7.0/.dir-locals.el000066400000000000000000000063451507574675700162620ustar00rootroot00000000000000((nil . ((geiser-repl-add-project-paths . ("module")) (geiser-guile-binary . "./guile"))) (scheme-mode . ((indent-tabs-mode . nil) (eval . (put 'with-syntax 'scheme-indent-function 1)) (eval . (put 'let/ec 'scheme-indent-function 1)) (eval . (put 'pass-if 'scheme-indent-function 1)) (eval . (put 'pass-if-exception 'scheme-indent-function 2)) (eval . (put 'pass-if-equal 'scheme-indent-function 2)) (eval . (put 'with-test-prefix 'scheme-indent-function 1)) (eval . (put 'with-test-prefix/c&e 'scheme-indent-function 1)) (eval . (put 'with-code-coverage 'scheme-indent-function 1)) (eval . (put 'with-statprof 'scheme-indent-function 1)) (eval . (put 'with-target 'scheme-indent-function 1)) (eval . (put 'let-gensyms 'scheme-indent-function 1)) (eval . (put 'let-fresh 'scheme-indent-function 2)) (eval . (put 'with-fresh-name-state 'scheme-indent-function 1)) (eval . (put 'with-fresh-name-state-from-dfg 'scheme-indent-function 1)) (eval . (put 'with-cps 'scheme-indent-function 1)) (eval . (put 'with-cps-constants 'scheme-indent-function 1)) (eval . (put 'with-lexicals 'scheme-indent-function 2)) (eval . (put 'build-cps-term 'scheme-indent-function 0)) (eval . (put 'build-cps-exp 'scheme-indent-function 0)) (eval . (put 'build-cps-cont 'scheme-indent-function 0)) (eval . (put 'rewrite-cps-term 'scheme-indent-function 1)) (eval . (put 'rewrite-cps-cont 'scheme-indent-function 1)) (eval . (put 'rewrite-cps-exp 'scheme-indent-function 1)) (eval . (put 'build-term 'scheme-indent-function 0)) (eval . (put 'build-exp 'scheme-indent-function 0)) (eval . (put 'build-cont 'scheme-indent-function 0)) (eval . (put 'rewrite-term 'scheme-indent-function 1)) (eval . (put 'rewrite-cont 'scheme-indent-function 1)) (eval . (put 'rewrite-exp 'scheme-indent-function 1)) (eval . (put '$letk 'scheme-indent-function 1)) (eval . (put '$letk* 'scheme-indent-function 1)) (eval . (put '$letconst 'scheme-indent-function 1)) (eval . (put '$continue 'scheme-indent-function 2)) (eval . (put '$branch 'scheme-indent-function 3)) (eval . (put '$switch 'scheme-indent-function 3)) (eval . (put '$prompt 'scheme-indent-function 3)) (eval . (put '$kargs 'scheme-indent-function 2)) (eval . (put '$kfun 'scheme-indent-function 4)) (eval . (put '$letrec 'scheme-indent-function 3)) (eval . (put '$kclause 'scheme-indent-function 1)) (eval . (put '$fun 'scheme-indent-function 1)) (eval . (put 'record-case 'scheme-indent-function 1)) (eval . (put 'syntax-parameterize 'scheme-indent-function 1)) (eval . (put 'with-additional-imports 'scheme-indent-function 1)) (eval . (put 'hoot:define-record-type 'scheme-indent-function 1)) (eval . (put 'import 'scheme-indent-function 0)) (eval . (put 'match-inst 'scheme-indent-function 1)) ))) guile-hoot-0.7.0/.forgejo/000077500000000000000000000000001507574675700153325ustar00rootroot00000000000000guile-hoot-0.7.0/.forgejo/workflows/000077500000000000000000000000001507574675700173675ustar00rootroot00000000000000guile-hoot-0.7.0/.forgejo/workflows/ci.yml000066400000000000000000000013311507574675700205030ustar00rootroot00000000000000on: [push] jobs: check: runs-on: guix steps: - run: git clone --depth=1 --branch=$GITHUB_REF_NAME https://codeberg.org/$GITHUB_REPOSITORY src - run: | set -e ./bootstrap.sh ./configure make -j${nproc} make check -j${nproc} shell: guix-ci -Df guix.scm -- {0} working-directory: src distcheck: runs-on: guix steps: - run: git clone --depth=1 --branch=$GITHUB_REF_NAME https://codeberg.org/$GITHUB_REPOSITORY src - run: | set -e ./bootstrap.sh ./configure make -j${nproc} make distcheck -j${nproc} shell: guix-ci -Df guix.scm -- {0} working-directory: src guile-hoot-0.7.0/.gitignore000066400000000000000000000006731507574675700156170ustar00rootroot00000000000000/Makefile /Makefile.in *.go *.log *.trs /reflect-wasm/*.wasm /examples/basic-types.wasm /test-wasm-assembler.log /aclocal.m4 /autom4te.cache/ /build-aux/ /config.log /config.status /configure /pre-inst-env /js-test /lib/Makefile /lib/Makefile.in /lib/hoot/char-prelude.scm /module/Makefile /module/Makefile.in /module/hoot/config.scm /doc/hoot.info /doc/hoot.html/ /doc/.dirstamp /examples/project-template/hello.wasm /examples/repl/repl.wasm guile-hoot-0.7.0/COPYING000066400000000000000000000261361507574675700146640ustar00rootroot00000000000000 Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. guile-hoot-0.7.0/LICENSE.txt000077700000000000000000000000001507574675700164722COPYINGustar00rootroot00000000000000guile-hoot-0.7.0/Makefile.am000066400000000000000000000103241507574675700156550ustar00rootroot00000000000000SUBDIRS = module lib js_runnerdir = $(pkgdatadir)/$(VERSION)/js-runner js_runner_DATA = \ js-runner/await-call.js \ js-runner/call.js \ js-runner/load.js \ js-runner/load-async.js \ js-runner/load-primitive.js reflect_jsdir = $(pkgdatadir)/$(VERSION)/reflect-js reflect_js_DATA = \ reflect-js/reflect.js reflect_wasmdir = $(pkgdatadir)/$(VERSION)/reflect-wasm REFLECT_WAT = \ reflect-wasm/reflect.wat \ reflect-wasm/wtf8.wat reflect_wasm_DATA = $(REFLECT_WAT:%.wat=%.wasm) CLEANFILES = $(reflect_wasm_DATA) SUFFIXES = .wat .wasm # The mkdir is necessary for 'make distcheck' since it's building in a # different directory than the project root. .wat.wasm: $(AM_V_GEN)$(MKDIR_P) $(dir $@) && \ $(top_builddir)/pre-inst-env $(GUILD) assemble-wasm -o "$@" "$<" $(top_builddir)/reflect-wasm/reflect.wasm: reflect-wasm/reflect.wat module/hoot/stdlib.scm $(AM_V_GEN)$(MKDIR_P) $(dir $@) && \ $(top_builddir)/pre-inst-env $(GUILD) assemble-wasm \ --stdlib="((@ (hoot stdlib) compute-stdlib) #t)" -o "$@" "$<" TEST_EXTENSIONS = .scm SCM_LOG_COMPILER = $(top_builddir)/pre-inst-env $(GUILE) AM_SCM_LOG_FLAGS = --no-auto-compile -L $(top_srcdir) JS_LOG_COMPILER = $(top_builddir)/js-test CLEANFILES += $(TESTS:test/%.scm=%.log) TESTS = \ test/test-assignment.scm \ test/test-atomics.scm \ test/test-bitwise.scm \ test/test-bytevectors.scm \ test/test-char-prelude.scm \ test/test-complex.scm \ test/test-constants.scm \ test/test-disassemble.scm \ test/test-division.scm \ test/test-environments.scm \ test/test-eval.scm \ test/test-expander.scm \ test/test-exceptions.scm \ test/test-expander.scm \ test/test-ffi.scm \ test/test-fibers.scm \ test/test-fibers-channels.scm \ test/test-fibers-conditions.scm \ test/test-fibers-operations.scm \ test/test-fibers-scheduler.scm \ test/test-fibers-streams.scm \ test/test-fibers-timers.scm \ test/test-fibers-waiter-queue.scm \ test/test-finalization.scm \ test/test-flonums.scm \ test/test-fluids.scm \ test/test-fractions.scm \ test/test-hash.scm \ test/test-hashtables.scm \ test/test-hashtables-doubly-weak.scm \ test/test-hashtables-guile.scm \ test/test-hashtables-weak-key.scm \ test/test-hashtables-weak-value.scm \ test/test-inline-wasm.scm \ test/test-ints.scm \ test/test-keywords.scm \ test/test-library-group.scm \ test/test-lower-globals.scm \ test/test-lower-stringrefs.scm \ test/test-lower.scm \ test/test-match.scm \ test/test-modules.scm \ test/test-number-to-string.scm \ test/test-numeric.scm \ test/test-pairs.scm \ test/test-ports.scm \ test/test-procedures.scm \ test/test-promises.scm \ test/test-prompts.scm \ test/test-read.scm \ test/test-records.scm \ test/test-regexps.scm \ test/test-string-to-number.scm \ test/test-strings.scm \ test/test-symbols.scm \ test/test-syntax-objects.scm \ test/test-time.scm \ test/test-tree-il.scm \ test/test-vectors.scm \ test/test-vm.scm \ test/test-wasm-assembler.scm \ test/test-weak-vectors.scm \ test/test-write.scm \ # info_TEXINFOS = doc/hoot.texi doc_hoot_TEXINFOS = doc/hoot.texi \ doc/apache-2.0.texi dvi: # Don't build dvi docs html-local: $(GUILE) --no-auto-compile doc/build-html.scm EXTRA_DIST = \ $(REFLECT_WAT) \ $(TESTS) \ $(EXTRA_WAT) \ $(js_runner_DATA) \ $(reflect_js_DATA) \ bin/eval.scm \ bin/call.scm \ bin/compile.scm \ bin/generate-char-prelude.scm \ bootstrap.sh \ guix.scm \ COPYING \ hoot.png \ README.md \ test/basic-types.wat \ test/basic-types.wasm \ test/utils.scm \ test/hashtable-utils.scm \ test/fixtures/hello \ doc/build-html.scm \ doc/hoot.css \ examples/project-template/hello.js \ examples/project-template/hello.scm \ examples/project-template/index.html \ examples/project-template/Makefile \ examples/project-template/manifest.scm \ examples/project-template/hello/document.scm \ examples/project-template/hello/element.scm \ examples/project-template/README.md \ # guile-hoot-0.7.0/README.md000066400000000000000000000170271507574675700151070ustar00rootroot00000000000000# Guile Hoot ![Hoot logo](./hoot.png) Hoot is an ahead-of-time, whole-program compiler for [Guile Scheme](https://gnu.org/software/guile) to WebAssembly (aka Wasm) developed by the [Spritely Institute](https://spritely.institute/). In addition to the compiler, Hoot contains a full WebAssembly toolchain with an assembler, a disassembler, a linker, an interpreter, etc. Hoot produces binaries that conform to the Wasm 3.0 specification which features tail calls and heap-allocated reference types with garbage collection. ## Compatibility Hoot is compatible with the following Wasm runtimes: - Firefox 121+ - Chrome 119+ - Safari 26+ - NodeJS 22+ Hoot is currently *unsupported* on WASI runtimes. ## Compilation and runtime A whole-program compilation approach has been chosen in order to create smaller binaries at the expense of increased compilation time. As we implement more of Scheme, we hope to preserve this "small programs compile to small files" property, rather than having every compiled program include the whole of Guile's standard library. Despite whole-program compilation, it's possible for multiple Hoot modules to be bound together and interoperate. Hoot makes a distinction between main and auxilary modules. Main modules include the full Scheme runtime and export their ABI whereas auxilary modules exclude the runtime and import their ABI from a main module. To run Hoot binaries on web browsers there is an associated JavaScript module that handles booting the Wasm modules with the necessary host imports and translates Scheme values to/from JavaScript. Some non-web targets are hosted by JavaScript implementations (e.g. NodeJS) and those can make use of the same support module. ## Project status Hoot has not yet achieved maximum Guile compatibility, but [R7RS-small Scheme](https://small.r7rs.org/) is well supported. Despite gaps in compatibility, Guile libraries such as [Spritely Goblins](https://spritely.institute/goblins/) are known to compile and run on Hoot. All Wasm features that Hoot relies upon are available in all major web browsers and NodeJS. To build and run Hoot, a bleeding-edge Guile built from the `main` branch in Git is required, as several necessary changes that have been upstreamed to Guile have not made it into a stable release yet. For a fuller picture of project status, including known limitations, see the ["Status" section of our documentation.](https://spritely.institute/files/docs/guile-hoot/latest/Status.html). ## But... why the name "Hoot"? We thought this project deserved a cute project name and mascot, and everyone at the time agreed an owl was nice, and Christine Lemmer-Webber had recently just drawn up this owl pixel art, and so it became the mascot. The name naturally flowed from there. ## Installing from a stable release Note that at the time of writing, Hoot requires a development version of Guile. This may not be the case at your time of reading! Below are system-specific instructions for installing Hoot. ### On Guix Hoot is already available in [Guix](https://guix.gnu.org/): ``` guix shell --pure guile-next guile-hoot ``` (The `--pure` flag is to reduce the likelihood of failure due to system-specific configuration. You may not need this flag.) ### On macOS (Homebrew) Hoot is [available in macOS thanks to to Alex Conchillo FlaquĆ© and the Guile Homebrew repository](https://github.com/aconchillo/homebrew-guile). Add the Guile Homebrew tap if you haven't already: ``` brew tap aconchillo/guile ``` If Guile is already installed with Homebrew, unlink it since we need a newer version: ``` brew unlink guile ``` Now, just install Hoot: ``` brew install guile-hoot ``` This will also install `guile-next`, a bleeding edge version of Guile, so it might take a while if there's no bottle available. ## Building from source ### Easy path: Use Guix This is by far the easiest path because Guix does all the hard work for you. First, clone the repository: ``` git clone https://codeberg.org/spritely/hoot cd hoot guix shell ./bootstrap.sh && ./configure && make ``` If everything went okay then you can now run `make check`: ``` make check ``` Did everything pass? Cool! That means Hoot works on your machine! ### Advanced path: Build dependencies on your own Maybe you want to understand better what Hoot is actually doing, or maybe you want to hack on the version of Guile used for Hoot, or etc! This section is for you. First, you need to build Guile from the `main` branch. Then you can clone and build this repo: ``` git clone https://codeberg.org/spritely/hoot cd hoot ./bootstrap.sh && ./configure && make ``` To run the test suite against a production Wasm host, you will need a V8 distribution such as NodeJS 22+ or a standalone V8 build. NodeJS is recommended. Building V8 is annoying, to say the least. You need to have `depot_tools` installed; see https://v8.dev/docs/source-code. Once you have that see https://v8.dev/docs/build to build. You will end up with a `d8` binary in `out/x64.release` (if you are on an x86-64 platform). We discourage this route except in the very unlikely case that you are developing a Hoot feature that requires a fresher V8 than NodeJS provides. If all that works you should be able to run the test suite: ``` make check ``` By default, the test suite runs against both V8 (either NodeJS or V8's `d8` tool) and Hoot's Wasm interpreter. If you want to run the test suite with just one or the other, you can use the `WASM_HOST` environment variable: ``` make check WASM_HOST=hoot # OR make check WASM_HOST=node # OR make check WASM_HOST=d8 ``` ## Try it out Hoot is a self-contained system, so the easiest way to try it is from the Guile REPL: ``` ./pre-inst-env guile ``` From the Guile prompt, enter the following to evaluate the program `42` in Hoot's built-in Wasm interpreter: ``` scheme@(guile-user)> ,use (hoot reflect) scheme@(guile-user)> (compile-value 42) $5 = 42 ``` More interestingly, Scheme procedures that live within the Wasm guest module can be called from Scheme as if they were host procedures: ``` scheme@(guile-user)> (define hello (compile-value '(lambda (x) (list "hello" x)))) scheme@(guile-user)> hello $6 = #> scheme@(guile-user)> (hello "world") $7 = # ``` Hoot also extends Guile's build tool `guild` with the `guild compile-wasm` subcommand which can be used to compile and (optionally) run a Scheme file: ``` echo 42 > 42.scm ./pre-inst-env guild compile-wasm --run 42.scm ``` The above command compiles `42.scm` to Wasm and runs the resulting binary in Hoot's Wasm interpreter. Here's how to run it with NodeJS instead: ``` ./pre-inst-env guild compile-wasm --run=node 42.scm ``` The binaries can be saved to disk, too, of course: ``` ./pre-inst-env guild compile-wasm -o 42.wasm 42.scm ``` To actually load `42.wasm` you could use the Hoot VM as mentioned above or use a production Wasm implementation such as a web browser. See the manual for further instructions on production deployment and full API documentation. ## Examples For quickly getting started with a new project, see `examples/project-template/README.md` for an explanation of how to use our project template. For more examples of using Hoot, check out a some of our other repos: * https://codeberg.org/spritely/hoot-ffi-demo * https://codeberg.org/spritely/hoot-repl * https://codeberg.org/spritely/hoot-game-jam-template ## Contributing Hoot's Git repository is hosted on Codeberg: https://codeberg.org/spritely/hoot Bug reports and other issues can be filed here: https://codeberg.org/spritely/hoot/issues Pull requests are very much welcome! guile-hoot-0.7.0/acinclude.m4000066400000000000000000000365561507574675700160310ustar00rootroot00000000000000## Autoconf macros for working with Guile. ## ## Copyright (C) 1998,2001, 2006, 2010, 2012, 2013, 2014, 2020 Free Software Foundation, Inc. ## ## This library is free software; you can redistribute it and/or ## modify it under the terms of the GNU Lesser General Public License ## as published by the Free Software Foundation; either version 3 of ## the License, or (at your option) any later version. ## ## This library is distributed in the hope that it will be useful, ## but WITHOUT ANY WARRANTY; without even the implied warranty of ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ## Lesser General Public License for more details. ## ## You should have received a copy of the GNU Lesser General Public ## License along with this library; if not, write to the Free Software ## Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ## 02110-1301 USA # serial 11 ## Index ## ----- ## ## GUILE_PKG -- find Guile development files ## GUILE_PROGS -- set paths to Guile interpreter, config and tool programs ## GUILE_FLAGS -- set flags for compiling and linking with Guile ## GUILE_SITE_DIR -- find path to Guile "site" directories ## GUILE_CHECK -- evaluate Guile Scheme code and capture the return value ## GUILE_MODULE_CHECK -- check feature of a Guile Scheme module ## GUILE_MODULE_AVAILABLE -- check availability of a Guile Scheme module ## GUILE_MODULE_REQUIRED -- fail if a Guile Scheme module is unavailable ## GUILE_MODULE_EXPORTS -- check if a module exports a variable ## GUILE_MODULE_REQUIRED_EXPORT -- fail if a module doesn't export a variable ## Code ## ---- ## NOTE: Comments preceding an AC_DEFUN (starting from "Usage:") are massaged ## into doc/ref/autoconf-macros.texi (see Makefile.am in that directory). # GUILE_PKG -- find Guile development files # # Usage: GUILE_PKG([VERSIONS]) # # This macro runs the @code{pkg-config} tool to find development files # for an available version of Guile. # # By default, this macro will search for the latest stable version of # Guile (e.g. 3.0), falling back to the previous stable version # (e.g. 2.2) if it is available. If no guile-@var{VERSION}.pc file is # found, an error is signalled. The found version is stored in # @var{GUILE_EFFECTIVE_VERSION}. # # If @code{GUILE_PROGS} was already invoked, this macro ensures that the # development files have the same effective version as the Guile # program. # # @var{GUILE_EFFECTIVE_VERSION} is marked for substitution, as by # @code{AC_SUBST}. # AC_DEFUN([GUILE_PKG], [AC_REQUIRE([PKG_PROG_PKG_CONFIG]) if test "x$PKG_CONFIG" = x; then AC_MSG_ERROR([pkg-config is missing, please install it]) fi _guile_versions_to_search="m4_default([$1], [3.0 2.2 2.0])" if test -n "$GUILE_EFFECTIVE_VERSION"; then _guile_tmp="" for v in $_guile_versions_to_search; do if test "$v" = "$GUILE_EFFECTIVE_VERSION"; then _guile_tmp=$v fi done if test -z "$_guile_tmp"; then AC_MSG_FAILURE([searching for guile development files for versions $_guile_versions_to_search, but previously found $GUILE version $GUILE_EFFECTIVE_VERSION]) fi _guile_versions_to_search=$GUILE_EFFECTIVE_VERSION fi GUILE_EFFECTIVE_VERSION="" _guile_errors="" for v in $_guile_versions_to_search; do if test -z "$GUILE_EFFECTIVE_VERSION"; then AC_MSG_NOTICE([checking for guile $v]) PKG_CHECK_EXISTS([guile-$v], [GUILE_EFFECTIVE_VERSION=$v], []) fi done if test -z "$GUILE_EFFECTIVE_VERSION"; then AC_MSG_ERROR([ No Guile development packages were found. Please verify that you have Guile installed. If you installed Guile from a binary distribution, please verify that you have also installed the development packages. If you installed it yourself, you might need to adjust your PKG_CONFIG_PATH; see the pkg-config man page for more. ]) fi AC_MSG_NOTICE([found guile $GUILE_EFFECTIVE_VERSION]) AC_SUBST([GUILE_EFFECTIVE_VERSION]) ]) # GUILE_FLAGS -- set flags for compiling and linking with Guile # # Usage: GUILE_FLAGS # # This macro runs the @code{pkg-config} tool to find out how to compile # and link programs against Guile. It sets four variables: # @var{GUILE_CFLAGS}, @var{GUILE_LDFLAGS}, @var{GUILE_LIBS}, and # @var{GUILE_LTLIBS}. # # @var{GUILE_CFLAGS}: flags to pass to a C or C++ compiler to build code that # uses Guile header files. This is almost always just one or more @code{-I} # flags. # # @var{GUILE_LDFLAGS}: flags to pass to the compiler to link a program # against Guile. This includes @code{-lguile-@var{VERSION}} for the # Guile library itself, and may also include one or more @code{-L} flag # to tell the compiler where to find the libraries. But it does not # include flags that influence the program's runtime search path for # libraries, and will therefore lead to a program that fails to start, # unless all necessary libraries are installed in a standard location # such as @file{/usr/lib}. # # @var{GUILE_LIBS} and @var{GUILE_LTLIBS}: flags to pass to the compiler or to # libtool, respectively, to link a program against Guile. It includes flags # that augment the program's runtime search path for libraries, so that shared # libraries will be found at the location where they were during linking, even # in non-standard locations. @var{GUILE_LIBS} is to be used when linking the # program directly with the compiler, whereas @var{GUILE_LTLIBS} is to be used # when linking the program is done through libtool. # # The variables are marked for substitution, as by @code{AC_SUBST}. # AC_DEFUN([GUILE_FLAGS], [AC_REQUIRE([GUILE_PKG]) PKG_CHECK_MODULES(GUILE, [guile-$GUILE_EFFECTIVE_VERSION]) dnl GUILE_CFLAGS and GUILE_LIBS are already defined and AC_SUBST'd by dnl PKG_CHECK_MODULES. But GUILE_LIBS to pkg-config is GUILE_LDFLAGS dnl to us. GUILE_LDFLAGS=$GUILE_LIBS dnl Determine the platform dependent parameters needed to use rpath. dnl AC_LIB_LINKFLAGS_FROM_LIBS is defined in gnulib/m4/lib-link.m4 and needs dnl the file gnulib/build-aux/config.rpath. AC_LIB_LINKFLAGS_FROM_LIBS([GUILE_LIBS], [$GUILE_LDFLAGS], []) GUILE_LIBS="$GUILE_LDFLAGS $GUILE_LIBS" AC_LIB_LINKFLAGS_FROM_LIBS([GUILE_LTLIBS], [$GUILE_LDFLAGS], [yes]) GUILE_LTLIBS="$GUILE_LDFLAGS $GUILE_LTLIBS" AC_SUBST([GUILE_EFFECTIVE_VERSION]) AC_SUBST([GUILE_CFLAGS]) AC_SUBST([GUILE_LDFLAGS]) AC_SUBST([GUILE_LIBS]) AC_SUBST([GUILE_LTLIBS]) ]) # GUILE_SITE_DIR -- find path to Guile site directories # # Usage: GUILE_SITE_DIR # # This looks for Guile's "site" directories. The variable @var{GUILE_SITE} will # be set to Guile's "site" directory for Scheme source files (usually something # like PREFIX/share/guile/site). @var{GUILE_SITE_CCACHE} will be set to the # directory for compiled Scheme files also known as @code{.go} files # (usually something like # PREFIX/lib/guile/@var{GUILE_EFFECTIVE_VERSION}/site-ccache). # @var{GUILE_EXTENSION} will be set to the directory for compiled C extensions # (usually something like # PREFIX/lib/guile/@var{GUILE_EFFECTIVE_VERSION}/extensions). The latter two # are set to blank if the particular version of Guile does not support # them. Note that this macro will run the macros @code{GUILE_PKG} and # @code{GUILE_PROGS} if they have not already been run. # # The variables are marked for substitution, as by @code{AC_SUBST}. # AC_DEFUN([GUILE_SITE_DIR], [AC_REQUIRE([GUILE_PKG]) AC_REQUIRE([GUILE_PROGS]) AC_MSG_CHECKING(for Guile site directory) GUILE_SITE=`$PKG_CONFIG --print-errors --variable=sitedir guile-$GUILE_EFFECTIVE_VERSION` AC_MSG_RESULT($GUILE_SITE) if test "$GUILE_SITE" = ""; then AC_MSG_FAILURE(sitedir not found) fi AC_SUBST(GUILE_SITE) AC_MSG_CHECKING([for Guile site-ccache directory using pkgconfig]) GUILE_SITE_CCACHE=`$PKG_CONFIG --variable=siteccachedir guile-$GUILE_EFFECTIVE_VERSION` if test "$GUILE_SITE_CCACHE" = ""; then AC_MSG_RESULT(no) AC_MSG_CHECKING([for Guile site-ccache directory using interpreter]) GUILE_SITE_CCACHE=`$GUILE -c "(display (if (defined? '%site-ccache-dir) (%site-ccache-dir) \"\"))"` if test $? != "0" -o "$GUILE_SITE_CCACHE" = ""; then AC_MSG_RESULT(no) GUILE_SITE_CCACHE="" AC_MSG_WARN([siteccachedir not found]) fi fi AC_MSG_RESULT($GUILE_SITE_CCACHE) AC_SUBST([GUILE_SITE_CCACHE]) AC_MSG_CHECKING(for Guile extensions directory) GUILE_EXTENSION=`$PKG_CONFIG --print-errors --variable=extensiondir guile-$GUILE_EFFECTIVE_VERSION` AC_MSG_RESULT($GUILE_EXTENSION) if test "$GUILE_EXTENSION" = ""; then GUILE_EXTENSION="" AC_MSG_WARN(extensiondir not found) fi AC_SUBST(GUILE_EXTENSION) ]) # GUILE_PROGS -- set paths to Guile interpreter, config and tool programs # # Usage: GUILE_PROGS([VERSION]) # # This macro looks for programs @code{guile} and @code{guild}, setting # variables @var{GUILE} and @var{GUILD} to their paths, respectively. # The macro will attempt to find @code{guile} with the suffix of # @code{-X.Y}, followed by looking for it with the suffix @code{X.Y}, and # then fall back to looking for @code{guile} with no suffix. If # @code{guile} is still not found, signal an error. The suffix, if any, # that was required to find @code{guile} will be used for @code{guild} # as well. # # By default, this macro will search for the latest stable version of # Guile (e.g. 3.0). x.y or x.y.z versions can be specified. If an older # version is found, the macro will signal an error. # # The effective version of the found @code{guile} is set to # @var{GUILE_EFFECTIVE_VERSION}. This macro ensures that the effective # version is compatible with the result of a previous invocation of # @code{GUILE_FLAGS}, if any. # # As a legacy interface, it also looks for @code{guile-config} and # @code{guile-tools}, setting @var{GUILE_CONFIG} and @var{GUILE_TOOLS}. # # The variables are marked for substitution, as by @code{AC_SUBST}. # AC_DEFUN([GUILE_PROGS], [_guile_required_version="m4_default([$1], [$GUILE_EFFECTIVE_VERSION])" if test -z "$_guile_required_version"; then _guile_required_version=3.0 fi _guile_candidates=guile _tmp= for v in `echo "$_guile_required_version" | tr . ' '`; do if test -n "$_tmp"; then _tmp=$_tmp.; fi _tmp=$_tmp$v _guile_candidates="guile-$_tmp guile$_tmp $_guile_candidates" done AC_PATH_PROGS(GUILE,[$_guile_candidates]) if test -z "$GUILE"; then AC_MSG_ERROR([guile required but not found]) fi _guile_suffix=`echo "$GUILE" | sed -e 's,^.*/guile\(.*\)$,\1,'` _guile_effective_version=`$GUILE -c "(display (effective-version))"` if test -z "$GUILE_EFFECTIVE_VERSION"; then GUILE_EFFECTIVE_VERSION=$_guile_effective_version elif test "$GUILE_EFFECTIVE_VERSION" != "$_guile_effective_version"; then AC_MSG_ERROR([found development files for Guile $GUILE_EFFECTIVE_VERSION, but $GUILE has effective version $_guile_effective_version]) fi _guile_major_version=`$GUILE -c "(display (major-version))"` _guile_minor_version=`$GUILE -c "(display (minor-version))"` _guile_micro_version=`$GUILE -c "(display (micro-version))"` _guile_prog_version="$_guile_major_version.$_guile_minor_version.$_guile_micro_version" AC_MSG_CHECKING([for Guile version >= $_guile_required_version]) _major_version=`echo $_guile_required_version | cut -d . -f 1` _minor_version=`echo $_guile_required_version | cut -d . -f 2` _micro_version=`echo $_guile_required_version | cut -d . -f 3` if test "$_guile_major_version" -gt "$_major_version"; then true elif test "$_guile_major_version" -eq "$_major_version"; then if test "$_guile_minor_version" -gt "$_minor_version"; then true elif test "$_guile_minor_version" -eq "$_minor_version"; then if test -n "$_micro_version"; then if test "$_guile_micro_version" -lt "$_micro_version"; then AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found]) fi fi elif test "$GUILE_EFFECTIVE_VERSION" = "$_major_version.$_minor_version" -a -z "$_micro_version"; then # Allow prereleases that have the right effective version. true else as_fn_error $? "Guile $_guile_required_version required, but $_guile_prog_version found" "$LINENO" 5 fi elif test "$GUILE_EFFECTIVE_VERSION" = "$_major_version.$_minor_version" -a -z "$_micro_version"; then # Allow prereleases that have the right effective version. true else AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found]) fi AC_MSG_RESULT([$_guile_prog_version]) AC_PATH_PROG(GUILD,[guild$_guile_suffix]) AC_SUBST(GUILD) AC_PATH_PROG(GUILE_CONFIG,[guile-config$_guile_suffix]) AC_SUBST(GUILE_CONFIG) if test -n "$GUILD"; then GUILE_TOOLS=$GUILD else AC_PATH_PROG(GUILE_TOOLS,[guile-tools$_guile_suffix]) fi AC_SUBST(GUILE_TOOLS) ]) # GUILE_CHECK -- evaluate Guile Scheme code and capture the return value # # Usage: GUILE_CHECK_RETVAL(var,check) # # @var{var} is a shell variable name to be set to the return value. # @var{check} is a Guile Scheme expression, evaluated with "$GUILE -c", and # returning either 0 or non-#f to indicate the check passed. # Non-0 number or #f indicates failure. # Avoid using the character "#" since that confuses autoconf. # AC_DEFUN([GUILE_CHECK], [AC_REQUIRE([GUILE_PROGS]) $GUILE -c "$2" > /dev/null 2>&1 $1=$? ]) # GUILE_MODULE_CHECK -- check feature of a Guile Scheme module # # Usage: GUILE_MODULE_CHECK(var,module,featuretest,description) # # @var{var} is a shell variable name to be set to "yes" or "no". # @var{module} is a list of symbols, like: (ice-9 common-list). # @var{featuretest} is an expression acceptable to GUILE_CHECK, q.v. # @var{description} is a present-tense verb phrase (passed to AC_MSG_CHECKING). # AC_DEFUN([GUILE_MODULE_CHECK], [AC_MSG_CHECKING([if $2 $4]) GUILE_CHECK($1,(use-modules $2) (exit ((lambda () $3)))) if test "$$1" = "0" ; then $1=yes ; else $1=no ; fi AC_MSG_RESULT($$1) ]) # GUILE_MODULE_AVAILABLE -- check availability of a Guile Scheme module # # Usage: GUILE_MODULE_AVAILABLE(var,module) # # @var{var} is a shell variable name to be set to "yes" or "no". # @var{module} is a list of symbols, like: (ice-9 common-list). # AC_DEFUN([GUILE_MODULE_AVAILABLE], [GUILE_MODULE_CHECK($1,$2,0,is available) ]) # GUILE_MODULE_REQUIRED -- fail if a Guile Scheme module is unavailable # # Usage: GUILE_MODULE_REQUIRED(symlist) # # @var{symlist} is a list of symbols, WITHOUT surrounding parens, # like: ice-9 common-list. # AC_DEFUN([GUILE_MODULE_REQUIRED], [GUILE_MODULE_AVAILABLE(ac_guile_module_required, ($1)) if test "$ac_guile_module_required" = "no" ; then AC_MSG_ERROR([required guile module not found: ($1)]) fi ]) # GUILE_MODULE_EXPORTS -- check if a module exports a variable # # Usage: GUILE_MODULE_EXPORTS(var,module,modvar) # # @var{var} is a shell variable to be set to "yes" or "no". # @var{module} is a list of symbols, like: (ice-9 common-list). # @var{modvar} is the Guile Scheme variable to check. # AC_DEFUN([GUILE_MODULE_EXPORTS], [GUILE_MODULE_CHECK($1,$2,$3,exports `$3') ]) # GUILE_MODULE_REQUIRED_EXPORT -- fail if a module doesn't export a variable # # Usage: GUILE_MODULE_REQUIRED_EXPORT(module,modvar) # # @var{module} is a list of symbols, like: (ice-9 common-list). # @var{modvar} is the Guile Scheme variable to check. # AC_DEFUN([GUILE_MODULE_REQUIRED_EXPORT], [GUILE_MODULE_EXPORTS(guile_module_required_export,$1,$2) if test "$guile_module_required_export" = "no" ; then AC_MSG_ERROR([module $1 does not export $2; required]) fi ]) ## guile.m4 ends here guile-hoot-0.7.0/bin/000077500000000000000000000000001507574675700143715ustar00rootroot00000000000000guile-hoot-0.7.0/bin/call.scm000066400000000000000000000051671507574675700160210ustar00rootroot00000000000000;;; Test script to compile Scheme expressions to wasm, then apply via V8 ;;; Copyright (C) 2023, 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. (use-modules (wasm assemble) (hoot compile) (hoot config) (ice-9 binary-ports) (ice-9 match) (ice-9 popen) (ice-9 textual-ports) (srfi srfi-64)) (define (unwind-protect body unwind) (call-with-values (lambda () (with-exception-handler (lambda (exn) (unwind) (raise-exception exn)) body)) (lambda vals (unwind) (apply values vals)))) (define (call-with-compiled-wasm-file wasm f) (let* ((wasm-port (mkstemp "/tmp/tmp-wasm-XXXXXX")) (wasm-file-name (port-filename wasm-port))) (put-bytevector wasm-port (assemble-wasm wasm)) (close-port wasm-port) (unwind-protect (lambda () (f wasm-file-name)) (lambda () (delete-file wasm-file-name))))) (define (run-v8 . args) (let* ((v8 (or %node %d8)) (pid (spawn v8 (cons v8 args)))) (exit (status:exit-val (cdr (waitpid pid)))))) (define (compile-call form) (let lp ((form form) (files '()) (first? #t)) (match form (() (let ((runner (in-vicinity %js-runner-dir "call.js"))) (apply run-v8 runner "--" %reflect-js-dir %reflect-wasm-dir (reverse files)))) ((x . form) (call-with-compiled-wasm-file (compile x #:import-abi? (not first?) #:export-abi? first?) (lambda (file) (lp form (cons file files) #f))))))) (define (read1 str) (call-with-input-string str (lambda (port) (let ((expr (read port))) (when (eof-object? expr) (error "No expression to evaluate")) (let ((tail (read port))) (unless (eof-object? tail) (error "Unexpected trailing expression" tail))) expr)))) (when (batch-mode?) (match (program-arguments) ((arg0 f . args) (compile-call (cons (read1 f) (map read1 args)))) ((arg0 . _) (format (current-error-port) "usage: ~a FUNC ARG...\n" arg0) (exit 1)))) guile-hoot-0.7.0/bin/compile.scm000066400000000000000000000040111507574675700165210ustar00rootroot00000000000000;;; Test script to compile a Scheme expression to wasm ;;; Copyright (C) 2023, 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. (use-modules (wasm assemble) (hoot compile) (ice-9 binary-ports) (ice-9 match)) (define* (compile-expr expr out #:key import-abi? export-abi?) (let ((bytes (assemble-wasm (compile expr #:import-abi? import-abi? #:export-abi? export-abi? #:dump-cps? #t #:dump-wasm? #t)))) (call-with-output-file out (lambda (port) (put-bytevector port bytes))))) (define (read1 str) (call-with-input-string str (lambda (port) (let ((expr (read port))) (when (eof-object? expr) (error "No expression to evaluate")) (let ((tail (read port))) (unless (eof-object? tail) (error "Unexpected trailing expression" tail))) expr)))) (when (batch-mode?) (match (program-arguments) ((arg0 . args) (let lp ((args args) (import-abi? #f) (export-abi? #f)) (match args (("--import-abi" . args) (lp args #t export-abi?)) (("--export-abi" . args) (lp args import-abi? #t)) ((str out) (compile-expr (read1 str) out #:import-abi? import-abi? #:export-abi? export-abi?)) (_ (format (current-error-port) "usage: ~a EXPR OUT.WASM\n" arg0) (exit 1))))))) guile-hoot-0.7.0/bin/eval.scm000066400000000000000000000045731507574675700160350ustar00rootroot00000000000000;;; Test script to compile a Scheme expression to wasm, then run via V8 ;;; Copyright (C) 2023, 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. (use-modules (wasm assemble) (hoot config) (hoot compile) (ice-9 binary-ports) (ice-9 match) (ice-9 popen) (ice-9 textual-ports) (srfi srfi-64)) (define (unwind-protect body unwind) (call-with-values (lambda () (with-exception-handler (lambda (exn) (unwind) (raise-exception exn)) body)) (lambda vals (unwind) (apply values vals)))) (define (call-with-compiled-wasm-file wasm f) (let* ((wasm-port (mkstemp "/tmp/tmp-wasm-XXXXXX")) (wasm-file-name (port-filename wasm-port))) (put-bytevector wasm-port (assemble-wasm wasm)) (close-port wasm-port) (unwind-protect (lambda () (f wasm-file-name)) (lambda () (delete-file wasm-file-name))))) (define (run-v8 . args) (let* ((v8 (or %node %d8)) (pid (spawn v8 (cons v8 args)))) (exit (status:exit-val (cdr (waitpid pid)))))) (define (compile-expr expr) (call-with-compiled-wasm-file (compile expr) (lambda (wasm-file-name) (define runner (in-vicinity %js-runner-dir "load.js")) (run-v8 runner "--" %reflect-js-dir %reflect-wasm-dir wasm-file-name)))) (define (read1 str) (call-with-input-string str (lambda (port) (let ((expr (read port))) (when (eof-object? expr) (error "No expression to evaluate")) (let ((tail (read port))) (unless (eof-object? tail) (error "Unexpected trailing expression" tail))) expr)))) (when (batch-mode?) (match (program-arguments) ((arg0 str) (compile-expr (read1 str))) ((arg0 . _) (format (current-error-port) "usage: ~a EXPR\n" arg0) (exit 1)))) guile-hoot-0.7.0/bin/generate-char-prelude.scm000066400000000000000000000164051507574675700212460ustar00rootroot00000000000000(use-modules (ice-9 match) (ice-9 pretty-print) (ice-9 format) (ice-9 textual-ports)) (define (generate-codepoint-lookup-table f) (define (visit-codepoint-range start end clauses) (define (adjoin-span cp val out) (match out (() (acons cp val '())) (((end . val*) . tail) (if (eqv? val val*) (acons cp val* tail) (acons cp val out))))) (define (fold-clauses clauses out) (match out (() clauses) (((end . val) (end* . val*) . out) (let ((stride (- end end*))) (define (finish start out) (let* ((span (- end start)) (nclauses (/ span stride))) (unless (and (exact-integer? nclauses) (positive? nclauses)) (error "unexpected" nclauses)) (fold-clauses (append (match nclauses (1 `(((,(if (= span 1) '= '<=) cp ,end) ,val))) (2 `(((<= cp ,end*) ,val*) ((<= cp ,end) ,val))) (_ `(((<= cp ,end) (if (logtest 1 ,(cond ((= 1 (logcount stride)) ;; Stride is a power of two. (define (quotient/shift expr shift) (if (zero? shift) expr `(ash ,expr ,shift))) ;; Compute the offset from the start of ;; the span, unless the start is already ;; aligned. (define offset (if (logtest (1+ start) (1- (ash stride 1))) `(- cp ,(1+ start)) 'cp)) (quotient/shift offset (- (logcount (1- stride))))) (else `(even? (quotient (- cp ,(1+ start)) ,stride))))) ,(if (even? nclauses) val val*) ,(if (even? nclauses) val* val)))))) clauses) out))) (let lp ((prev-end end*) (prev-val val*) (out out) (expected val*) (alternate val)) (match out (() (let ((end (1- start))) (if (= end (- prev-end stride)) (finish end '()) (finish prev-end (acons prev-end prev-val out))))) (((end . val) . tail) (cond ((and (= end (- prev-end stride)) (eqv? prev-val expected)) (lp end val tail alternate expected)) (else (finish prev-end (acons prev-end prev-val out))))))))) (((end . val)) (cons `((<= cp ,end) ,val) clauses)))) (let lp ((cp start) (out '())) (if (<= cp end) (lp (1+ cp) (adjoin-span cp (f (integer->char cp)) out)) (fold-clauses clauses out)))) (define* (make-binary-search v #:optional (start 0) (end (vector-length v))) (cond ((= start end) (if (= start (vector-length v)) `(error "unreachable") (match (vector-ref v start) ((test expr) expr)))) (else (let ((mid (ash (+ start end) -1))) (match (vector-ref v mid) ((((or '= '<=) 'cp val) _) `(if (<= cp ,val) ,(make-binary-search v start mid) ,(make-binary-search v (1+ mid) end)))))))) (let* ((clauses '()) (clauses (visit-codepoint-range #xe000 #x10ffff clauses)) (clauses (visit-codepoint-range 0 #xd7ff clauses))) `(lambda (cp) ,(make-binary-search (list->vector clauses))))) (define (generate-codepoint-bit-lookup-table f) (define max-codepoint-bits 21) (define level-0-shift 16) (define level-0-size (ash 1 (- max-codepoint-bits level-0-shift))) (define level-1-shift 8) (define level-1-size (ash 1 (- level-0-shift level-1-shift))) (define level-1-mask (1- level-1-size)) (define level-2-size (ash 1 level-1-shift)) (define level-2-mask (1- level-2-size)) (define (empty-bitmap) #f) (define (adjoin bitmap n) (let ((i0 (ash n (- level-0-shift))) (i1 (logand (ash n (- level-1-shift)) level-1-mask)) (i2 (logand n level-2-mask))) ;; Could replace with functional setters. (define (vector-set v i x) (vector-set! v i x) v) (define (bitvector-set bv i) (bitvector-set-bit! bv i) bv) (define (adjoin/2 bv) (let ((bv (or bv (make-bitvector level-2-size #f)))) (bitvector-set bv i2))) (define (adjoin/1 v) (let ((v (or v (make-vector level-1-size #f)))) (vector-set v i1 (adjoin/2 (vector-ref v i1))))) (define (adjoin/0 v) (let ((v (or v (make-vector level-0-size #f)))) (vector-set v i0 (adjoin/1 (vector-ref v i0))))) (adjoin/0 bitmap))) (define (visit-codepoint-range start end bitmap) (let lp ((cp start) (bitmap bitmap)) (if (<= cp end) (lp (1+ cp) (if (f (integer->char cp)) (adjoin bitmap cp) bitmap)) bitmap))) (let* ((bitmap (visit-codepoint-range 0 #xd7ff (empty-bitmap))) (bitmap (visit-codepoint-range #xe000 #x10ffff bitmap))) `(lambda (cp) (define-syntax and-let* (syntax-rules () ((and-let* () body) body) ((and-let* ((var val) . bindings) body) (let ((var val)) (and var (and-let* bindings body)))))) (and-let* ((v (vector-ref ',bitmap (ash cp ,(- level-0-shift)))) (bv (vector-ref v (logand (ash cp ,(- level-1-shift)) ,level-1-mask)))) (bitvector-ref bv (logand cp ,level-2-mask)))))) (define (make-char-mapper f) (define (diff ch) (- (char->integer (f ch)) (char->integer ch))) `(lambda (ch) (let ((cp (char->integer ch))) (integer->char (+ cp (,(generate-codepoint-lookup-table diff) cp)))))) (define (make-char-predicate f) `(lambda (ch) (,(generate-codepoint-bit-lookup-table f) (char->integer ch)))) (when (batch-mode?) (match (program-arguments) ((_) (define (<< str) (put-string (current-output-port) str)) (define (pp expr) (newline (current-output-port)) (pretty-print expr (current-output-port))) (<< ";; This file was generated by generate-char-stdlib.scm.\n") (define-syntax-rule (generate-procs (gen proc) ...) (begin (pp `(define proc ,(gen proc))) ...)) (generate-procs (make-char-mapper char-upcase) (make-char-mapper char-downcase) (make-char-predicate char-upper-case?) (make-char-predicate char-lower-case?) (make-char-predicate char-alphabetic?) (make-char-predicate char-numeric?) (make-char-predicate char-whitespace?))) ((arg0 . _) (format (current-error-port) "usage: ~a\n" arg0) (exit 1)))) guile-hoot-0.7.0/bin/graph-libs.scm000077500000000000000000000147261507574675700171420ustar00rootroot00000000000000#!/usr/bin/env guile !# (use-modules (ice-9 textual-ports) (ice-9 match) (ice-9 format) ((srfi srfi-1) #:select (append-map partition)) (srfi srfi-9) (web uri)) ;; decl := edge | node | attr-decl | graph (define-record-type (make-edge src dst attrs) edge? (src edge-src) (dst edge-dst) (attrs edge-attrs)) (define-record-type (make-node id attrs) node? (id node-id) (attrs node-attrs)) (define-record-type (make-attr-decl kind attrs) attr-decl? (kind attr-decl-kind) ; 'node 'graph or 'edge (attrs attr-decl-attrs)) (define-record-type (make-graph id decls attrs) graph? (id graph-id) (decls graph-decls) (attrs graph-attrs)) (define (compute-node-attrs name) `((href . ,(string-append "https://gitlab.com/spritely/guile-hoot/-/blob/main/lib/" (string-join (map symbol->string name) "/") ".scm")) (fontname . Valkyrie) (tooltip . ,(object->string name)))) (define (module->decls name imports) (cons (make-node name (compute-node-attrs name)) (map (lambda (mod) (make-edge name mod '((headport . n) (tailport . s)))) imports))) (define (visit-r6rs-library name imports) ;; fixme: versions (define (import-name spec) (match spec (('only spec . _) (import-name spec)) (('rename spec . _) (import-name spec)) (('except spec . _) (import-name spec)) (('prefix spec _) (import-name spec)) (('library name) name) (spec spec))) (module->decls name (map import-name imports))) (define (visit-guile-library name imports) (define (import-name spec) (match spec ((name #:select _) name) ((name #:hide _) name) ((name #:prefix _) name) ((name #:renamer _) name) (name name))) (module->decls name (map import-name imports))) (define (keyword-like-symbol? x) (and (symbol? x) (string-prefix? ":" (symbol->string x)))) (define (visit-file file) (call-with-input-file file (lambda (port) (match (read port) (('library name exports ('import . specs) . body) (visit-r6rs-library name specs)) (('define-module name . args) (let lp ((args args) (imports '()) (pure? #f)) (match args (() (let ((imports (if pure? imports (cons '(guile) imports)))) (visit-guile-library name imports))) (((? keyword-like-symbol? kw) . args) (lp (cons (keyword-like-symbol->keyword kw) args) imports pure?)) ((#:pure . args) (lp args imports #t)) ((#:no-backtrace . args) (lp args imports #t)) ((#:use-module spec . args) (lp args (cons spec imports) pure?)) ((#:autoload spec bindings . args) (lp args (cons spec imports) pure?)) (((? keyword?) kwarg . args) (lp args imports pure?)) (_ (error "unexpected define-module args" args))))) (expr (format (current-error-port) "~a: not a recognized library\n" file) '()))))) (define (write-graph graph) (define (id-repr id) (match id (#f #f) ((? string?) id) (_ (object->string id)))) (define (write-attr attr) (match attr ((k . v) (format #t "~s=~s;" (id-repr k) (id-repr v))))) (define (write-attr-stmt attr) (write-attr attr) (newline)) (define (write-attr-list attrs) (unless (null? attrs) (format #t " [") (for-each write-attr attrs) (format #t "]"))) (define (write-endpoint ep) (match ep (($ ) (write-decl ep)) (id (format #t "~s" (id-repr id))))) (define (write-decl decl) (match decl (($ id attrs) (format #t "~s" (id-repr id)) (write-attr-list attrs) (format #t ";\n")) (($ src dst attrs) (write-endpoint src) (format #t " -> ") (write-endpoint dst) (write-attr-list attrs) (format #t ";\n")) (($ kind attrs) (format #t "~a" kind) (write-attr-list attrs) (format #t ";\n")) (($ id decls attrs) (format #t "subgraph ~@[~s ~]{\n" (id-repr id)) (for-each write-attr-stmt attrs) (for-each write-decl decls) (format #t "}\n")))) (match graph (($ id decls attrs) (format #t "strict digraph ~@[~s ~]{\n" (id-repr id)) (for-each write-attr-stmt attrs) (for-each write-decl decls) (format #t "}\n")))) (define (compute-graph decls) (define colors '(indianred steelblue limegreen aquamarine purple gold lightgrey hotpink)) (define attributed-colors (make-hash-table)) (define (get-color id) (or (hash-ref attributed-colors id) (let ((color (car colors))) (set! colors (cdr colors)) (hash-set! attributed-colors id color) color))) (define (add-node-attrs id attrs) (match id ((id0 . id+) (append (match id+ ((id1) `((label . ,id1))) (_ '())) `((color . ,(get-color id0)) (style . filled) (shape . box)) attrs)))) (call-with-values (lambda () (partition node? decls)) (lambda (nodes decls) (define node-defs (make-hash-table)) (for-each (match-lambda (($ id attrs) (hash-set! node-defs id #t))) nodes) (define synthesized-nodes '()) (define (maybe-synthesize! id) (unless (hash-ref node-defs id) (hash-set! node-defs id #t) (set! synthesized-nodes (cons (make-node id (add-node-attrs id '())) synthesized-nodes)))) (for-each (match-lambda (($ src dst attrs) (maybe-synthesize! src) (maybe-synthesize! dst))) decls) (make-graph #f (append synthesized-nodes (map (lambda (node) (match node (($ id attrs) (make-node id (add-node-attrs id attrs))))) nodes) decls) '((concentrate . true) (nodesep . "0.02")))))) (when (batch-mode?) (match (program-arguments) ((arg0) (format (current-error-port) "usage: ~a FILE...\n" arg0) (exit 1)) ((arg0 . libs) (write-graph (compute-graph (append-map visit-file libs)))))) guile-hoot-0.7.0/bin/optimize.scm000066400000000000000000000037711507574675700167450ustar00rootroot00000000000000;;; Test script to show high-level optimization of Scheme expressions ;;; Copyright (C) 2023, 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. (use-modules (language tree-il) (hoot compile) (system base compile) (system base language) (ice-9 match) (ice-9 pretty-print) (ice-9 textual-ports)) (define (read1 str) (call-with-input-string str (lambda (port) (let ((expr (read port))) (when (eof-object? expr) (error "No expression to evaluate")) (let ((tail (read port))) (unless (eof-object? tail) (error "Unexpected trailing expression" tail))) expr)))) (define* (optimize expr #:key (optimization-level (default-optimization-level)) (opts '()) import-abi?) (define lower-tree-il ((language-lowerer (lookup-language 'tree-il)) optimization-level opts)) (let* ((env #f) (tree-il (scheme->sealed-tree-il expr #:import-abi? import-abi?)) (optimized (lower-tree-il tree-il env))) (pretty-print (tree-il->scheme optimized env)))) (when (batch-mode?) (match (program-arguments) ((arg0 . args) (let lp ((args args) (import-abi? #f)) (match args (("--import-abi" . args) (lp args #t)) ((expr) (optimize (read1 expr) #:import-abi? import-abi?)) (_ (format (current-error-port) "usage: ~a [--import-abi] EXPR\n" arg0) (exit 1))))))) guile-hoot-0.7.0/bin/run-file.scm000066400000000000000000000046221507574675700166220ustar00rootroot00000000000000;;; Test script to compile a Scheme expression to wasm, then run via V8 ;;; Copyright (C) 2023, 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. (use-modules (wasm assemble) (hoot compile) (hoot config) (ice-9 binary-ports) (ice-9 match) (ice-9 popen) (ice-9 textual-ports) (srfi srfi-64)) (define (unwind-protect body unwind) (call-with-values (lambda () (with-exception-handler (lambda (exn) (unwind) (raise-exception exn)) body)) (lambda vals (unwind) (apply values vals)))) (define (call-with-compiled-wasm-file wasm f) (let* ((wasm-port (mkstemp "/tmp/tmp-wasm-XXXXXX")) (wasm-file-name (port-filename wasm-port))) (put-bytevector wasm-port (assemble-wasm wasm)) (close-port wasm-port) (unwind-protect (lambda () (f wasm-file-name)) (lambda () (delete-file wasm-file-name))))) (define (run-v8 . args) (let* ((v8 (or %node %d8)) (pid (spawn v8 (cons v8 args)))) (exit (status:exit-val (cdr (waitpid pid)))))) (define* (compile-and-run input-file #:key dump-cps? dump-wasm? emit-names? (compile-opts '())) (call-with-compiled-wasm-file (call-with-input-file input-file (lambda (in) (read-and-compile in #:dump-cps? dump-cps? #:dump-wasm? dump-wasm? #:emit-names? emit-names? #:opts compile-opts))) (lambda (wasm-file-name) (define runner (in-vicinity %js-runner-dir "load.js")) (run-v8 runner "--" %reflect-js-dir %reflect-wasm-dir wasm-file-name)))) (when (batch-mode?) (match (program-arguments) ((arg0 str) (compile-and-run str)) ((arg0 . _) (format (current-error-port) "usage: ~a FILE\n" arg0) (exit 1)))) guile-hoot-0.7.0/bootstrap.sh000077500000000000000000000000401507574675700161670ustar00rootroot00000000000000#!/bin/sh exec autoreconf -vif guile-hoot-0.7.0/ci-manifest.scm000066400000000000000000000006631507574675700165310ustar00rootroot00000000000000(use-modules (guix) (guix packages) (ice-9 match) (srfi srfi-1)) (define hoot-inputs (filter-map (match-lambda ((_ (? package? package) output) (list package output)) ((_ (? package? package)) package) (_ #f)) ; ignore source inputs, etc. (package-development-inputs (load (string-append (dirname (current-filename)) "/guix.scm"))))) (packages->manifest hoot-inputs) guile-hoot-0.7.0/configure.ac000066400000000000000000000017721507574675700161160ustar00rootroot00000000000000dnl -*- Autoconf -*- AC_INIT(guile-hoot, 0.7.0) AC_CONFIG_SRCDIR(module) AC_CONFIG_AUX_DIR([build-aux]) AM_INIT_AUTOMAKE([1.12 foreign silent-rules subdir-objects color-tests parallel-tests -Woverride -Wno-portability]) AM_SILENT_RULES([yes]) AC_CONFIG_FILES([Makefile module/Makefile lib/Makefile]) AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) AC_CONFIG_FILES([module/hoot/config.scm]) # Prepare a version of $datadir that does not contain references to # shell variables. Snarfed from Guix. hoot_prefix="`eval echo $prefix | sed -e"s|NONE|/usr/local|g"`" hoot_datadir="`eval eval echo $datadir | sed -e "s|NONE|$hoot_prefix|g"`" AC_SUBST([hoot_datadir]) GUILE_PKG([3.0]) GUILE_PROGS # Find Guile's module source files. GUILE_LIBRARY_DIR="`$PKG_CONFIG --variable=pkgdatadir guile-$GUILE_EFFECTIVE_VERSION`/$GUILE_EFFECTIVE_VERSION" AC_SUBST(GUILE_LIBRARY_DIR) # V8-based JS+Wasm runtimes (optional) AC_PATH_PROG([NODE], [node]) AC_SUBST([NODE]) AC_PATH_PROG([D8], [d8]) AC_SUBST([D8]) AC_OUTPUT guile-hoot-0.7.0/design/000077500000000000000000000000001507574675700150725ustar00rootroot00000000000000guile-hoot-0.7.0/design/ABI.md000066400000000000000000000460471507574675700160220ustar00rootroot00000000000000# Guile on WebAssembly: ABI [TOC] ## Data representation ### `SCM` unitype Scheme is an untyped language; any value can be stored in the common `SCM` unitype. Which concrete kind of value a given `SCM` holds can be determined by inspecting the value. (Of course, Guileā€™s compiler can unbox values and sometimes will be able to work in e.g. raw `f64` values. But we need a story for the general case). Since we are targetting the [GC MVP](https://github.com/WebAssembly/gc/blob/master/proposals/gc/MVP.md), we can represent `SCM` as `(ref eq)`. There is no need to allow nullability in this type. ### Immediates All immediates (fixnums, chars, bools, etc) are encoded as `(ref i31)` values. The 231 possible values are partitioned by tagging. The partition is the similar to [what native Guile does](http://git.savannah.gnu.org/cgit/guile.git/tree/module/system/base/types/internal.scm?h=wip-tailify#n101), except that the bottom 0 bit is left off and we eliminate some intermediate 0 bits. The fixnum range is therefore the same as in native Guile for a 32-bit target: \[-229, 229-1\]. Note that there is a risk here, that [`i31ref` gets punted to post-MVP](https://github.com/WebAssembly/gc/issues/320), but this appears to be unlikely. ### Heap objects In native Guile, there are immediate values and heap objects. Immediate values have their contents directly in the bits of the `SCM`. Heap objects are `SCM` values that are pointers to the heap. The type of the object is encoded in the first word of memory pointed to by the `SCM` value. In WebAssembly, garbage-collected objects can also also be associated with a type identifier which WebAssembly programs can introspect over, for example to branch to a label if a value has a given type. We will use these built-in capabilities when implementing the various Scheme data types. ## Calling convention In order to support lightweight concurrency via delimited continuations and variable argument counts, Guile-on-WebAssembly uses the standard WebAssembly function call mechanism in a strange way. On the side of continuations, the basic idea is that the compiler from Guile to WebAssembly will transform the program so that all calls are tail calls. Non-tail calls within a function are transformed so that the caller pushs the live values flowing to the return point onto an explicit stack, pushes the return continuation then tail-calls the callee. Returning from a function is transforms so that the callee pops the return continuation from the stack and tail-calls it. For full details, see [`tailify.scm` from the `wip-tailify` Guile branch](http://git.savannah.gnu.org/cgit/guile.git/tree/module/language/cps/tailify.scm?h=wip-tailify#n19). The advantage of this approach is that with an explicit stack representation, we can capture and reinstate delimited continuations, and write debuggers in terms of continuations whose structure can be inspected by Guile instead of the host WebAssembly system. The transformation is minimal, so that e.g. inner loops without calls are still as fast as direct-style compilation. (This calling convention may be obviated by either the [typed continuations or the fiber-based stack switching proposal](https://github.com/WebAssembly/stack-switching), but we don't see either of these features reaching consensus and shipping before 2025 or so.) Additionally, Guile functions can accept a variable number of arguments, whereas WebAssembly functions have a fixed type. In the general case we may need to pass arguments via a global argument-passing array. The first few arguments can be passed as parameters though. The number of arguments is also passed as a function parameter. Since all calls are tail calls, this convention applies to returning values as well. ### Dynamic stack The dynamic stack associates stack frames with `dynamic-wind` winders, prompts, individual fluid bindings, and dynamic states (whole sets of fluid bindings). Not yet specified. Really upstream Guile should be using continuation marks here, but we don't do this yet. ### Dynamic state See below for more on fluids and threads, but basically Guile should keep a cache of the current values of some dynamically-scoped variables. Not yet specified. ### Return stack The return stack is for stack-allocated continuations: basically those that correspond to the return points of non-tail calls in the source program. There will be separate stacks for `SCM` values, raw `i64` and `f64` values, and `(ref func)` return continuations, but the concrete representation remains to be specified. ## Type definitions ### Immediate data types An immediate is a fixnum, a char, or an oddball. All immediate values are encoded as a `(ref i31)`. The `i32` payload is extracted from the `(ref i31)` via sign extension, using `i31.get_s`. If the low bit of the payload is `#b0`, the value is a fixnum, and its signed integer value is in the high bits of payload. If the low 2 bits of the payload are `#b11`, the value is a char, and its codepoint is in the high bits of the payload. The sign bit will always be unset, because codepoints only go up to 221. Otherwise, the possible payloads are: - `#b000001`: 1: `#f` - `#b000101`: 5: `nil` - `#b001101`: 13: `'()` (null) - `#b010001`: 17: `#t` - `#b100001`: 33: the unspecified value - `#b101001`: 41: EOF - `#b111001`: 57: the undefined value (used internally) Some common oddball tests: - `null?`: check for null or nil; `(= (logand payload #b110111) #b000101)` - `false?`: check for false or nil; `(= (logand payload #b111011) #b000001)` - `elisp-false?`: check for false or nil or null; `(= (logand payload #b110011) #b000001)` ### Utility data types ```wat (type $raw-immutable-bitvector (array i32)) (type $raw-immutable-bytevector (array i8)) (type $raw-bitvector (array (mut i32))) (type $raw-bytevector (array (mut i8))) (type $raw-scmvector (array (mut (ref eq)))) ``` ### Continuation types The functions residualized by the tailify transform take a variable number of arguments. The number of values to take is passed to the function as an argument. The first three arguments are passed in parameters; any addition arguments get passed through a global array. If a function has fewer than three parameters, you can pass any value as the argument, for example `(i31.new (i32.const 0))`. Since we tailify everything, all calls are tail calls, so there are no return values. ```wat (type $kvarargs (func (param $nargs i32) (param $arg0 (ref eq)) (param $arg1 (ref eq)) (param $arg2 (ref eq)) (result))) ``` ### Heap types All Guile objects which are not represented as `(ref i31)` are "heap objects". These objects are all subtypes of `$heap-object`: ```wat (type $void-struct (struct)) (type $heap-object (sub $void-struct (struct (field $hash (mut i32))))) ``` There are subtypes for each concrete kind of object that Guile uses (approximately 20 types). As a WebAssembly type system detail, note that usually two types that have the same shape will be deemed equivalent and thus indistinguishable. It is the case that there are Guile objects that have the same shape. However we use the "hybrid nominal typing" facility to declare our types as being distinct, even when some of them have the same shape. By wrapping all our types in a `rec` block, we ensure that dynamic type checks can be made with a simple `ref.test`. For symbols and keywords, the `$hash` field is eagerly computed based on the string-hash of the underlying string. For other data types, the hash is computed lazily. A hash of 0 indicates an uninitialized hash. Bit 0 is always set if the hash is initialized. Otherwise for immediate values, there is a simple bit-mixing hash function. #### References to host facilities ```wat (type $extern-ref (sub $heap-object (struct (field $hash (mut i32)) (field $val (ref extern))))) ``` Sometimes we want to refer to a reference-typed value from the host, so one data type is an `$extern-ref`. #### Heap numbers ```wat (type $heap-number (sub $heap-object (struct (field $hash (mut i32))))) ``` There is a supertype for heap numbers, in case we need to quickly check that a non-fixnum is indeed a number. Then there are the concrete heap number types. ```wat (type $bignum (sub $heap-number (struct (field $hash (mut i32)) (field $val (ref extern))))) (type $flonum (sub $heap-number (struct (field $hash (mut i32)) (field $val f64)))) (type $complex (sub $heap-number (struct (field $hash (mut i32)) (field $real f64) (field $imag f64)))) (type $fraction (sub $heap-number (struct (field $hash (mut i32)) (field $num (ref eq)) (field $denom (ref eq))))) ``` #### Pairs ```wat (type $pair (sub $heap-object (struct (field $hash (mut i32)) (field $car (mut (ref eq))) (field $cdr (mut (ref eq)))))) ``` There is also a `$mutable-pair` subtype of `$pair`, with the same fields. `car` requires that the object be a `$pair`, but `set-car!` requires the subset of `$pair` values which are also `$mutable-pair`. #### Vectors ```wat (type $vector (sub $heap-object (struct (field $hash (mut i32)) (field $vals (ref $raw-scmvector))))) ``` There is also a `$mutable-vector` subtype of `$vector` with the same fields. You can get the length of the vector using `array.length` on the `$vals` field. #### Bytevectors ```wat (type $bytevector (sub $heap-object (struct (field $hash (mut i32)) (field $vals (ref $raw-bytevector))))) ``` There is also a `$mutable-bytevector` subtype of `$bytevector` with the same fields. You can get the length of the bytevector using `array.length` on the `$vals` field. #### Bitvectors We need an explicit length which is generally smaller than the storage space in the raw `i32` array. ```wat (type $bitvector (sub $heap-object (struct (field $hash (mut i32)) (field $len i32) (field $bits (ref $raw-bitvector))))) ``` There is also a `$mutable-bitvector` subtype of `$bitvector` with the same fields. #### Strings ```wat (type $string (sub $heap-object (struct (field $hash (mut i32)) (field $str (mut (ref string)))))) ``` It would be nice to just have `(ref string)` be the string representation, but [`stringref` is not a subtype of `eqref`](https://github.com/WebAssembly/stringref/issues/20). Therefore we have to wrap strings with a tagged struct. But, this also gives us the possibility to have a hashq field, and to possibly mutate the string (by replacing its contents). There is also a `$mutable-string` subtype of `$string` with the same fields. #### Procedures ```wat (type $proc (sub $heap-object (struct (field $hash (mut i32)) (field $func (ref $kvarargs))))) ``` A procedure is just another name for a function. A `$proc` is a tagged function. Some functions close over a set of free variables; for them, there are subtypes of `$proc`: ``` (type $closure1 (sub $proc (struct (field $hash (mut i32)) (field $func (ref $kvarargs)) (field $free0 (ref eq))))) (type $closure2 (sub $proc (struct (field $hash (mut i32)) (field $func (ref $kvarargs)) (field $free0 (ref eq)) (field $free1 (ref eq))))) ;; ... ``` The set of closure types will depend on what is needed by the code being compiled, and are not part of the `rec` block of distinct types. Also note that in the future, WebAssembly will support funcrefs which are themselves closures; in that case we can avoid the separate `$closureN` types, storing the data in the funcref directly. #### Symbols and keywords ```wat (type $symbol (sub $heap-object (struct (field $hash (mut i32)) (field $name (ref string))))) (type $keyword (sub $heap-object (struct (field $hash (mut i32)) (field $name (ref $symbol))))) ``` How to compute the symbol's hash is not yet determined. #### Variables and atomic boxes ```wat (type $variable (sub $heap-object (struct (field $hash (mut i32)) (field $val (mut (ref eq)))))) (type $atomic-box (sub $heap-object (struct (field $hash (mut i32)) (field $val (mut (ref eq)))))) ``` WebAssembly does support multiple threads, but there is no multi-thread support for GC objects, so for the time being atomic boxes don't need to use atomic operations. #### Hash tables We use a simple buckets-and-chains hash table, implemented in Scheme. ```wat (type $hash-table (sub $heap-object (struct (field $hash (mut i32)) (field $size (mut (ref i31))) (field $buckets (ref $vector))))) ``` #### Weak tables ```wat (type $weak-table (sub $heap-object (struct (field $hash (mut i32)) (field $val (ref extern))))) ``` The external value held by the weak table is a host-supplied weak map. #### Dynamic state ```wat (type $fluid (sub $heap-object (struct (field $hash (mut i32)) (field $init (ref eq))))) (type $dynamic-state (sub $heap-object (struct (field $hash (mut i32)) (field $val (ref extern))))) ``` In native Guile, a fluid is essentially a key and a dynamic state is a weak hash table mapping all fluids to their values. At run-time there is a per-thread cache for faster access to fluid values. There will have to be some run-time support routines for fluids. #### Syntax and macros ```wat (type $syntax (sub $heap-object (struct (field $hash (mut i32)) (field $expr (ref eq)) (field $wrap (ref eq)) (field $module (ref eq)) (field $source (ref eq))))) ``` I dearly hope that we can avoid having `psyntax` compiled to WebAssembly for any module that doesn't include `eval`. Still, `read-syntax` can produce syntax objects, which is a nice way of associating source info with objects; it's a type in native Guile, so I guess it makes sense to hollow out a space for it for Guile-on-WebAssembly. Note there is also a `scm_tc16_macro` for syntax transformers in native Guile, that we will also need to implement at some point. #### Multi-dimensional arrays In this first version, we'll punt on these. We should check with Daniel Lloda about the state of his rewrite of arrays in Scheme. #### Ports We take inspiration from how native Guile represents ports. However for both WASI and Web environments, we can assume that I/O routines are all capable of returning a promise instead of blocking, so we don't need explicit support for e.g. read or write wait FDs; instead we can assume that we use the pure-Scheme [suspendable port implementation](http://git.savannah.gnu.org/cgit/guile.git/tree/module/ice-9/suspendable-ports.scm?h=wip-tailify), so delimited continuation suspend and resume will just work. We can also simplify and assume UTF-8 encoding for textual I/O on ports. ```wat (type $port-type (struct (field $name (ref string)) ;; in guile these are (port, bv, start, count) -> size_t (field $read (ref null $proc)) ;; could have a more refined type (field $write (ref null $proc)) (field $seek (ref null $proc)) ;; (port, offset, whence) -> offset (field $close (ref null $proc)) ;; (port) -> () (field $get-natural-buffer-sizes (ref null $proc)) ;; port -> (rdsz, wrsz) (field $random-access? (ref null $proc)) ;; port -> bool (field $input-waiting (ref null $proc)) ;; port -> bool (field $truncate (ref null $proc)) ;; (port, length) -> () ;; Guile also has GOOPS classes here. )) (type $port (sub $heap-object (struct (field $hash (mut i32)) (field $pt (ref $port-type)) (field $stream (mut (ref eq))) (field $file_name (mut (ref eq))) (field $position (ref $pair)) (field $read_buf (mut (ref eq))) ;; A 5-vector (field $write_buf (mut (ref eq))) ;; A 5-vector (field $write_buf_aux (mut (ref eq))) ;; A 5-vector (field $read_buffering (mut i32)) (field $refcount (mut i32)) (field $rw_random (mut i8)) (field $properties (mut (ref eq)))))) ``` The meanings of these various fields are as in native Guile; you have to go spelunking a bit to find this information as the port representation isn't public API/ABI. Also, there is quite a bit of run-time work needed here. In native Guile there is also a "port-with-print-state" data type; unclear if we will need this eventually. Probably not. #### Structs ```wat (type $struct (sub $heap-object (struct (field $hash (mut i32)) (field $vtable (mut (ref null $vtable)))))) (type $vtable (sub $struct (struct (field $hash (mut i32)) (field $vtable (mut (ref null $vtable))) (field $field0 (mut (ref eq))) (field $field1 (mut (ref eq))) (field $field2 (mut (ref eq))) (field $field3 (mut (ref eq)))))) ``` Guile's structs are the underlying facility that implements records and object-orientation. They have the oddity that their vtable is also a struct with at least 4 fields. The `$struct` and `$vtable` definitions are inside the `rec` block. Specific struct types as needed by the program will be residualized as needed. If the struct has more than 4 fields, it may store them in a heap vector. ``` (type $struct1 (sub $struct (struct (field $hash (mut i32)) (field $vtable (mut (ref null $struct4))) (field $field0 (mut (ref eq)))))) (type $struct2 (sub $struct (struct (field $hash (mut i32)) (field $vtable (mut (ref null $struct4))) (field $field0 (mut (ref eq))) (field $field1 (mut (ref eq)))))) (type $struct3 (sub $struct (struct (field $hash (mut i32)) (field $vtable (mut (ref null $struct4))) (field $field0 (mut (ref eq))) (field $field1 (mut (ref eq))) (field $field2 (mut (ref eq)))))) (type $struct4 (sub $struct (struct (field $hash (mut i32)) (field $vtable (mut (ref null $struct4))) (field $field0 (mut (ref eq))) (field $field1 (mut (ref eq))) (field $field2 (mut (ref eq))) (field $field3 (mut (ref eq)))))) (type $structN (sub $struct (struct (field $hash (mut i32)) (field $vtable (mut (ref null $struct4))) (field $field0 (mut (ref eq))) (field $field1 (mut (ref eq))) (field $field2 (mut (ref eq))) (field $field3 (mut (ref eq))) (field $tail (ref $raw-scmvector))))) ``` ## Not-yet-supported types Weak vectors are not yet supported. Regular expressions: not yet supported. Would be a JS callout. Random states. Charsets. First-class threads, mutexes, and condition variables. The representation of first-class delimited and undelimited continuations is currently unspecified. (It will be a slice of all stacks, though.) ## Open questions Should we be annotating struct types with `final`? The MVP document mentions it but binaryen does not seem to support it. ## JS API Wasm GC values (and thus Guile-on-Wasm values) are opaque to JavaScript; they can pass through JS by reference but if JS is to do something with them on its own, there need to be explicit conversions to and from JS, for example to unpack the integer in a fixnum. There will be a side Wasm library to do this. guile-hoot-0.7.0/design/log.md000066400000000000000000000272241507574675700162040ustar00rootroot00000000000000# Project log An attempt at keeping a record of where we were when, and speculation on what the log might contain soon ## The past ### 2023-02-15 Project kickoff. Beginnings of the [compilation strategy](./ABI.md) document, and the first WebAssembly files built by hand, to make sure that the compilation strategy will work out. Lots of confusion around nominal types. For context, Scheme is quite monomorphic in flavor (e.g. `length` only works on lists) but it has to contend with dynamically-typed objects. You don't need to do so much polymorphic dispatch but you do need to be able to quickly dynamically check that an object is of the expected type. For WebAssembly as hosted by a JS implementation, each GC object starts with an internal "map"/"shape"/"structure"/"hidden class" word (the nomenclature depends on the engine but it's all the same); the fastest checks will simply check than an object's first word has a given value. However the abstraction that exposes cheap map word checks to WebAssembly (nominal types / run-time types) was [removed from the GC MVP](https://github.com/WebAssembly/gc/issues/275). You can still do dynamic checks, but they are structural, and some objects have the same shape. So in these first couple weeks there was significant confusion on whether structural checks would be sufficient, or whether you would need a tag word. ### 2023-02-27 First, some work on making the [basic-types](../examples/basic-types.wat) example represent all fundamental types that there are in Guile. Hash tables threw a bit of a spanner in the works. The initial idea was to punt to the embedder; for a JS host, you'd use [`Map`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Map). But how would you implement identity-based hashing in Wasmtime? Assuming a GC that moves objects, you can't simply use object address as the key. It's asking too much of the host to implement some strange side table. So, as the JVM does, we now explicitly include space for a hash code in all objects, even pairs (which before we were trying to keep lean, as in Guile). On the positive side this hash word can contain a tag, so dynamic checks are cheaper than before. Relatedly, because [`string` is not a subtype of `eq`](https://github.com/WebAssembly/stringref/issues/20), we needed to wrap strings anyway; this gives us a way to have mutable strings if we end up needing to have that. All in all, the arc is towards using a little more memory, but not taking short-cuts to compromise on semantics, relative to what native Guile does. In the end it will be fine. Some additional run-time work in the basic-types example to show how to implement a symbol table, a keyword table, string hashing, struct vtables, and so on. ### 2023-03-03 Now that the hand-written basic-types example supports all types that Guile does, we start on making WebAssembly from Scheme. First, a port of [wassemble](https://github.com/wingo/wassemble) [to Scheme](../module/wasm/assemble.scm). As we go, we update wassemble for more recent additions to the wasm standard. There are actually a couple parts of the assembler: one to take s-expression input that mostly corresponds to the WebAssembly [textual grammar](https://webassembly.github.io/spec/core/text/index.html), and parses to Guile records; and one that take a Guile WebAssembly record and assembles it to bytes. Having gotten that to work, next up was [a disassembler](../module/wasm/parse.scm). This one was built to handle all of the WebAssembly that V8 can handle, including experimental extensions. For GC, this corresponds to the [Milestone 6 MVP](https://docs.google.com/document/d/1DklC3qVuOdLHSXB5UXghM_syCh-4cMinQ50ICiXnK3Q/edit#) document. Representing all WebAssembly features required some expansions to the [../module/wasm/types.scm](Guile WebAssembly data type definitions), and corresponding updates to the assembler. Finally, after getting the parser working and the assembler back up to speed on (almost) all the features that the parser can parse, tied things together with some [tests](./test/test-wasm-assembler.scm). ### 2023-03-28 Gave a talk about our efforts at [BOB 2023](https://wingolog.org/archives/2023/03/20/a-world-to-win-webassembly-for-the-rest-of-us). Seems to have been well-received. On the implementation side, started looking at the [tailify](http://git.savannah.gnu.org/cgit/guile.git/tree/module/language/cps/tailify.scm?h=wip-tailify) pass. Right now if you [compile](./compile.scm) the trivial Scheme program `42`, you get this: ```scheme L0: v0 := self L1(...) L1: receive() v1 := const 42 ; val v2 := restore1[ptr]() ; ret tail calli v2(v1) ``` Here we see two blocks. (Really it's just one, but it renders as two because the `$kentry` has two successors: the `$kclause` and the `$ktail`). `L0` is the entry, which binds `self` as the closure and then continues to `L1` which parses the args, expecting 0 additional args. Then we define the return value (`42`), then pop a `ptr` from the stack and call it indirectly (`tail calli`). The thing is, `ptr` is a really lazy way to describe the type of the continuation. Can we assume that it's a return continuation or are there other kinds of pointers that we might see? Turns out, yes, for now at least we can assume it's a return continuation; the other uses of `ptr`-typed locals in native Guile are for interior pointers for strings and pointers to the struct-unboxed-field bitvector, neither of which we will have for the wasm target. But, we still have some work to do on the compiler front-end, to avoid eager "instruction explosion" of CPS primitives in `(language tree-il compile-cps)` to primitives that correspond to the native Guile VM rather than what we will use in wasm. ### 2023-04-06 Aaaaaaahhhhh, finally: ``` guild compile-wasm -o 42.wasm 42.scm wrote `42.wasm` ``` We also have a new [reflect.wat](../js-runtime/reflect.wat) / [reflect.js](../js-runtime/reflect.js) run-time library to allow these WebAssembly files to be loaded in web browsers or other places where you have a JavaScript implementation with a capable WebAssembly implementation. ### 2023-05-05 Some progress, in that the compiler now supports all kinds of constant literals, and we are starting to implement the different primcalls. Then, non-tail function calls; once that is working we'll be close to having a working Scheme. ### 2023-05-15 Some interesting progress: the test suite and JS host harness has been enhanced so as to compile multiple compilation units and have them interoperate. To do this we need to ensure they share the same run-time (stack pointers, etc). Probably there are some more guard-rails to make here but for now it's an interesting development. We now compile value returns, tail calls, conditionals, and a few minimal primcalls (add, add/immediate, sub, sub/immediate, mul). We can do non-tail calls too. Recursive fac and fib run (though don't handle overflow to bignum yet); speed appears to currently be about 15x slower than Guile native. Something to work on over time. ### 2023-05-22 Conversations from Hoot sync meeting: - Land Robin's MRs on self-assembling - Move stdlib from hoot compile to hoot stdlib - Add function to WAT parsing module to parse an expression, unfolding at same time - Use that function as part of compute stdlib - Need to be able to raise our abstraction for defining runtime functions! In medium term wanna define more functions in scheme. Want to compile expressions with lexically available environment, but that's kind of a separate thing Might be in medium term that we could define functions in scheme that have their implementation in webassembly Add special logic to compiler to emit WASM code instead of in other ways to compile a function (kinda like inline-asm) Gotta make it nicer to write WASM! Especially all those damn make-type-use things. If you're parsing WAT, you get around a lot of those In that file maybe have more emacs indentation rules so the code doesn't look terrible. Should put in local variables or `.dir-locals.el` or etc. Prioritization for this week: - Land self-assembly MRs - Move stdlib from hoot compile to hoot stdlib - Compute stdlib return standard wasm module but parse from WAT instead of more imperative mode. Put it in the WAT DSL instead of in scheme. - Use WAT more. Less explicit assembly records, more WAT parsing ### 2023-06-22 Moved the unify-returns pass into Guile (`wip-tailify` branch), and made it so that Guile can select Hoot-specific backend passes to its CPS. But the big change is that Guile no longer eagerly explodes e.g. `vector-length` into generic low-level `word-ref/immediate` instructions when converting from Tree-IL to CPS; we keep the various type checks and bailouts as part of explicit control flow, but CPS conversion residualizes e.g. `vector-ref` etc. This will let Hoot allocate objects with Wasm/GC typed objects. ### 2023-07-04 Finished adding support for vectors, pairs, closures, variables/boxes, structs, and started on bytevectors. Next up will be the dynamic environment. ## The near future ### Cast optimizations In WebAssembly, `vector-length` needs to work on a value of type `(struct $vector)`. But generally what is flowing around is the `(ref eq)` unitype, so we have to introduce explicit `ref.cast` operations. Still, type checks can help us automatically recover this information: because `vector-length` is dominated by a `vector?` check, we should be able to use `br_on_cast` or similar. Right now we're just going to insert casts right before `vector-ref` et al, as we emit the `vector-ref`. But really we should instead do like this: 1. Add a pass to explicitly insert `$vector` casts right before each vector accessor (or pairs, structs, etc). 2. That pass also inserts casts on the true branch of each `vector?` primcall. 3. Run CSE to eliminate casts at the access points and instead use the `$vector` cast after the type check. This is already a win because probably there's more than one access. 4. When emitting wasm, detect a `br_on_cast` if a branch is followed by a cast. Not sure how this integrates with the "beyond relooper" design though! ### Other potential starter tasks Some good starter tasks for new contributors: - The "wat" component of the assembler isn't yet updated for reference types / GC. It would be nice to fix that so that we can replace our use of binaryen to use our own assembler instead. - We should have a wasm->wat serializer. Probably a good way to test that the wat->wasm parser for reftypes is working: take `basic-test.wasm`, parse to records via `parse-wasm`, then take it to wat and then back to wasm and binary. - It would be nice to add a "symbolizer" pass for parsed wasm files. That way you can write some of the standard library in wat, use binaryen to compile, optimize, and validate it, and when you want to pull in parts of the standard library you can just parse the compiled wasm via `compute-stdlib` in `(hoot compile)`. To do this though, intramodule references need to be symbolic (by-name) rather than by index, to allow the module to be picked apart and combined with the generated wasm. - The [WebAssembly tool conventions](https://github.com/WebAssembly/tool-conventions/blob/main/Linking.md) define a way to serialize names to object files. Probably we should do this, for debuggability. - Currently the subset of the Scheme language that is supported is quite minimal. We need to expand this. See [(hoot compile)](../module/hoot/compile.scm), anywhere it says "unimplemented", and add tests to [`test-constants.scm`](../test/test-constants.scm) or some other file there. guile-hoot-0.7.0/doc/000077500000000000000000000000001507574675700143665ustar00rootroot00000000000000guile-hoot-0.7.0/doc/apache-2.0.texi000066400000000000000000000243351507574675700170060ustar00rootroot00000000000000 Apache License Version 2.0, January 2004 @uref{http://www.apache.org/licenses/} TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION @enumerate @item Definitions. ``License'' shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. ``Licensor'' shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. ``Legal Entity'' shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, ``control'' means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. ``You'' (or ``Your'') shall mean an individual or Legal Entity exercising permissions granted by this License. ``Source'' form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. ``Object'' form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. ``Work'' shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). ``Derivative Works'' shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. ``Contribution'' shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, ``submitted'' means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as ``Not a Contribution.'' ``Contributor'' shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. @item Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. @item Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. @item Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a ``NOTICE'' text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. @item Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. @item Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. @item Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an ``AS IS'' BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE@. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. @item Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. @item Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. @end enumerate END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets ``[]'' replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same ``printed page'' as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the ``License''); you may not use this file except in compliance with the License. You may obtain a copy of the License at @uref{http://www.apache.org/licenses/LICENSE-2.0} Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an ``AS IS'' BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. guile-hoot-0.7.0/doc/build-html.scm000066400000000000000000000061231507574675700171350ustar00rootroot00000000000000;;; Copyright 2023 David Thompson ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;; Texinfo's 'makeinfo --html' command generates disappointing HTML. ;; To deal with it, we post-process the HTML files that it generates ;; to add in syntax highlighting and a better stylesheet. (use-modules (htmlprag) (ice-9 ftw) (ice-9 match) (srfi srfi-1) (syntax-highlight) (syntax-highlight scheme)) (define %html-dir "hoot.html") (define %image-dir (string-append %html-dir "/images")) (define %css-file "hoot.css") ;; Work within the context of the docs directory. (chdir (dirname (current-filename))) ;; Generate the docs with makeinfo. (unless (zero? (system* "makeinfo" "--html" "-o" %html-dir "hoot.texi")) (error "failed to build manual")) ;; Copy our CSS file to the build artifact directory. (copy-file %css-file (string-append %html-dir "/" %css-file)) ;; Gather up all the HTML files that were generated. (define html-files (filter-map (lambda (f) (and (string-suffix? ".html" f) (string-append %html-dir "/" f))) (scandir %html-dir))) ;; Post-process a single document. (define (prettify-sxml sxml) (match sxml ;; Add our stylesheet to the section... (('head nodes ...) `(head ,@(map prettify-sxml nodes) (link (@ (rel "stylesheet") (href "hoot.css"))))) ;; ...and remove the default style! (('style _ ...) "") ;; Highlight Scheme code. ((or ('pre ('@ ('class "lisp")) lines ...) ('div ('@ ('class "example lisp")) "\n" ('pre ('@ ('class "verbatim")) lines ...))) (let ((highlights (highlight lex-scheme (string-concatenate lines)))) `(pre (@ (class "lisp")) ,@(highlights->sxml highlights)))) ;; Leaf nodes. ((or (? symbol?) (? string?)) sxml) ;; Recursively descend through SXML nodes. Requires two cases: ;; One for nodes with attributes, and one for nodes without. (((? symbol? tag) ('@ attrs ...) nodes ...) (cons* tag (cons '@ attrs) (map prettify-sxml nodes))) (((? symbol? tag) nodes ...) (cons tag (map prettify-sxml nodes))))) ;; Parse HTML strictly. (%strict-tokenizer? #t) ;; Apply post-processing to all HTML files, overwriting their original ;; contents. (for-each (lambda (f) (let ((sxml (call-with-input-file f html->sxml))) (call-with-output-file f (lambda (port) (write-sxml-html (prettify-sxml sxml) port))))) html-files) guile-hoot-0.7.0/doc/hoot.css000066400000000000000000000071521507574675700160560ustar00rootroot00000000000000/* Copyright 2023 Christine Lemmer-Webber */ /* Copyright 2023 David Thompson */ /* Licensed under the Apache License, Version 2.0 (the "License"); */ /* you may not use this file except in compliance with the License. */ /* You may obtain a copy of the License at */ /* http://www.apache.org/licenses/LICENSE-2.0 */ /* Unless required by applicable law or agreed to in writing, software */ /* distributed under the License is distributed on an "AS IS" BASIS, */ /* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. */ /* See the License for the specific language governing permissions and */ /* limitations under the License. */ @font-face { font-family: 'VT323'; font-style: normal; src: url('https://spritely.institute/static/fonts/vt323/VT323-Regular.ttf'); } @font-face { font-family: 'Sahitya'; font-style: normal; src: url('https://spritely.institute/static/fonts/sahitya/Sahitya-Regular.ttf'); } @font-face { font-family: 'Sahitya'; font-style: normal; font-weight: bold; src: url('https://spritely.institute/static/fonts/sahitya/Sahitya-Bold.ttf'); } @font-face { font-family: 'PT Serif'; font-style: normal; src: url('https://spritely.institute/static/fonts/pt_serif/PTSerif-Regular.ttf'); } @font-face { font-family: 'PT Serif'; font-style: normal; font-weight: bold; src: url('https://spritely.institute/static/fonts/pt_serif/PTSerif-Bold.ttf'); } @font-face { font-family: 'PT Serif'; font-style: italic; src: url('https://spritely.institute/static/fonts/pt_serif/PTSerif-Italic.ttf'); } @font-face { font-family: 'PT Serif'; font-style: italic; font-weight: bold; src: url('https://spritely.institute/static/fonts/pt_serif/PTSerif-BoldItalic.ttf'); } @font-face { font-family: 'Inconsolata'; font-style: normal; font-weight: 400; src: url('https://spritely.institute/static/fonts/inconsolata/Inconsolata-Regular.ttf'); } @font-face { font-family: 'Inconsolata'; font-style: normal; font-weight: 700; src: url('https://spritely.institute/static/fonts/inconsolata/Inconsolata-Bold.ttf'); } body { font-family: 'PT Serif',Times,Times New Roman,serif; background-color: #fcf9fd; color: #060606; font-size: 18px; line-height: 140%; text-rendering: optimizeLegibility; margin: 0 auto; } @media (min-width: 1140px) { body { max-width: 52rem; } } @media (min-width: 800px) and (max-width: 1140px) { body { max-width: 52rem; } } @media (max-width: 800px) { body { margin: 1rem; } } a { color: #a576d4; text-decoration: none; transition: text-shadow .22s; } a:hover { text-shadow: 0px 0px 2px #cfccd4; } a:visited { color: #8f5ac4; text-decoration: none; } samp, code { font-family: "Inconsolata",monospace; background-color: #eee; } blockquote { padding-left: 2rem; border-left: 5px solid #ddd; font-style: italic; } pre.example, pre.lisp, pre.verbatim { font-family: "Inconsolata",monospace; line-height: 110%; min-width: 100%; max-width: 100%; padding: 1rem; background-color: #110e13; color: #deeed6; border-radius: 4px; display: inline-block; overflow: scroll; } .footnote h5 { font-weight: normal; } /* Syntax Highlighting */ .syntax-special, .syntax-element { color: #8e6da6; font-weight: bold; } .syntax-symbol { color: #e0ceed; } .syntax-string { color: #95e454; } .syntax-keyword, .syntax-attribute { color: #e5786d; } .syntax-comment { color: #999; } .syntax-open, .syntax-close { color: #00768b; } guile-hoot-0.7.0/doc/hoot.texi000066400000000000000000003767721507574675700162600ustar00rootroot00000000000000\input texinfo @c -*- texinfo -*- @c %**start of header @setfilename hoot.info @settitle Guile Hoot @documentencoding UTF-8 @documentlanguage en @syncodeindex pg cp @c %**end of header @dircategory The Algorithmic Language Scheme @direntry * Hoot: (hoot). Scheme to Wasm compiler backend for Guile and Wasm toolchain. @end direntry @finalout @titlepage @title Guile Hoot @author David Thompson (@email{dave@@spritely.institute}) @author The Spritely Institute @end titlepage @contents @ifnottex @node Top @top Guile Hoot This is the manual for Guile Hoot, a Scheme to WebAssembly compiler backend for @url{https://gnu.org/software/guile,GNU Guile} and general purpose Wasm toolchain. Both this manual and Guile Hoot itself are released under Apache v2. See @ref{License} for more information. @end ifnottex @menu * Introduction:: What's the deal with Wasm, anyway? * Compilation:: Using the compiler and development tools. * Reflection:: Using Hoot modules from the host environment. * Deployment:: Deploy Hoot binaries. * Scheme reference:: Hoot-specific Scheme extensions. * Toolchain reference:: General purpose Wasm tools. * Contributing:: Lend a hand! * License:: Copying, distributing, and using this text. * Index:: @end menu @node Introduction @chapter Introduction Guile Hoot is a Scheme to WebAssembly (henceforth referred to as @emph{Wasm}) compiler backend for @url{https://gnu.org/software/guile,GNU Guile} and a general purpose Wasm toolchain. Wasm is an abstract but low-level binary compilation target that can run on all major web browsers, and increasingly in other, more ``native'' contexts, as well. For over two decades, JavaScript has been @emph{the} official language of the web, and while the language has improved a lot over the years, its design leaves much to be desired. Thus web developers looked for ways to bring their preferred language to the browser to use instead. In the past, the only option available was to @emph{compile that language to JavaScript!} This approach worked in some sense but it was unideal because many languages do not map cleanly to JavaScript. In the case of Scheme, for example, the lack of a tail call facility makes compiling tail-recursive Scheme code unpleasant. At long last, thanks to Wasm, it has become possible to use an alternative language with fewer compromises and better performance. Hoot aims to bring Guile's ``whole self'' to the web, as well as to other Wasm GC runtimes. Hoot is being developed by the @url{https://spritely.institute,Spritely Institute} in collaboration with @url{https://www.igalia.com/,Igalia} to advance Spritely's mission to build the infrastructure for a completely decentralized social Internet. And for that mission, what better platform to target than the web browser? @url{https://spritely.institute/goblins/,Goblins}, Spritely's distributed object programming environment, is primarily written in Guile. So, to meet users where they are at @emph{and} not use JavaScript at the same time, Spritely needs a Guile to Wasm compiler. A secondary goal of Hoot is to advocate for all dynamic programming languages' (Python, Ruby, etc.) rightful place on the client-side web. The Wasm 1.0 specification was not a habitable environment for languages that require a garbage collector. The Wasm GC proposal, among others, has made it possible for dynamic languages to target Wasm in a real way. However, such advances are not without their detractors. Without the necessary support, a useful proposal will never make it into the core specification. For example, strings are a particularly controversial subject in the WebAssembly Community Group and proposals that would greatly benefit Hoot and other languages have not reached consensus. Implementing and targeting emergent and useful Wasm proposals helps those proposals find their way into the core specification. A rising tide lifts all boats, as they say, and while we may be little schemers, we want our work to help advance the Wasm standard for all dynamic languages. @menu * Supported platforms:: Where you can run Hoot. * Status:: What works. What doesn't. * Installation:: Setting up Hoot. * Tutorial:: Compiling your first Scheme program to Wasm. @end menu @node Supported platforms @section Supported platforms Hoot's binaries conform to the Wasm 3.0 specification and are supported on the following Wasm runtimes: @itemize @item Firefox 121 or later @item Chrome 119 or later @item Safari 26 or later @item NodeJS 22.3.0 or later @end itemize Hoot is currently @emph{unsupported} on WASI runtimes. @node Status @section Status Hoot is still in active development and its API should be considered unstable and subject to change in future releases. Hoot currently supports nearly all of the R7RS-small Scheme specification, a bit of R6RS, along with a subset of Guile-specific functionality such as @inlinefmtifelse{html, @url{https://www.gnu.org/software/guile/manual/html_node/Prompts.html, prompts}, @ref{Prompts,,,Guile Reference}}. The largest missing pieces from Hoot's R7RS-small support are environments and evaluation (@code{environment}, @code{eval}, etc.) which would allow for runtime interpretation of Scheme. Future releases will add support for all of R7RS-small and eventually full Guile-flavored Scheme. To compile Scheme to Wasm, Hoot takes advantage of the features in the Wasm 3.0 specification. The most important of these features are tail calls and GC reference types. The @code{return_call} family of instructions has made the implementation of Scheme's tail recursive procedure call semantics relatively straightforward. GC reference type instructions allow for heap allocated objects (and immediates via the @code{i31} type) that are managed by the Wasm runtime. This allows Hoot to take advantage of production garbage collectors already present in web browsers, obviating the need to implement and ship a GC which would be both inferior to the host's and a major source of binary bloat. There's an additional Wasm proposal that Hoot has been built on that has, unfortunately, not found its way into the core Wasm specification: stringref. We still emit stringref instructions as it is useful in the compilation pipeline but it is reduced to being an intermediate form. A lowering pass replaces stringref instructions with something resembling the JS String Builtins proposal. @node Installation @section Installation @node Binary installation @subsection Binary installation Currently, Hoot is available from only one GNU/Linux distribution: @url{https://guix.gnu.org,GNU Guix}. Guix may also be used as an additional package manager on top of another distribution such as Debian. If you have Guix, trying Hoot is easy: @example guix shell guile-next guile-hoot @end example This will create a temporary shell environment in which you can try Hoot. It's important that the @code{guile-next} package is included because Hoot currently relies upon features in Guile that have not yet made it into a stable release. @node Building from source @subsection Building from source The @emph{easiest} way to get everything necessary to build Hoot is by using the @url{https://guix.gnu.org,GNU Guix} package manager for which we provide a @file{guix.scm} file ready for use with @command{guix shell}: @example cd guile-hoot/ guix shell @end example @command{guix shell} will download/compile all required dependencies and start an interactive shell that is ready to use for building Hoot. To use Hoot without Guix requires building Guile from source. Hoot is currently undergoing a lot of development and requires a bleeding-edge Guile built against the @code{main} branch. Eventually Hoot will just require a stable release of Guile. With a sufficiently fresh Guile, via Guix or otherwise, the build can begin. If you are building from a Git checkout rather than an official release tarball, the first step is to bootstrap the build system: @example ./bootstrap.sh @end example Release tarballs have a pre-bootstrapped build system and do not require the above step. Now, build Hoot: @example ./configure make @end example If you'd like to install Hoot onto your system, run: @example sudo make install @end example The GNU build system defaults to @file{/usr/local} as the installation prefix. This can be changed by re-running the configure script: @example ./configure --prefix=/some/where/else sudo make install @end example To try out Hoot without installing it, use the @file{pre-inst-env} wrapper to launch Guile in the context of the Hoot build directory: @example ./pre-inst-env guile @end example If you installed Guile to your system, simply run @command{guile}. If everything went well, you will be greeted with a Guile REPL prompt. Regardless of installation status, to verify that Guile can find the Hoot modules, run: @lisp scheme@@(guile-user)> ,use (hoot compile) @end lisp If there is no error then congratulations! Your setup is correct. Proceed to the tutorial for a crash course in how to use Hoot, or see later chapters for an API reference. @subsubsection Running the test suite This is entirely optional, but if you'd like further verification that your build is good (or perhaps you're packaging Hoot for distribution), the test suite can be run via @command{make check}. By default, the tests are run against two Wasm runtimes: Hoot's own Wasm interpreter and either @url{https://nodejs.org,NodeJS} (version 22+) or @url{https://v8.dev/,V8} via the @command{d8} tool. Getting V8 can be tricky, and will most likely require you to @url{https://v8.dev/docs/build,compile it from source.} It's a pain! To skip all of that trouble and just run the tests against the built-in interpreter, run: @example make check WASM_HOST=hoot @end example @node Tutorial @section Tutorial This tutorial will cover compiling and running Scheme programs from the command-line, the Guile REPL, and the web browser. Let's start with a simple program in a file called @file{tutorial.scm}: @lisp (import (scheme base)) (list 'hoot 'hoot) @end lisp This program can be compiled to Wasm and run in Hoot's Wasm interpreter with a single command: @example guild compile-wasm --run tutorial.scm @end example This will print the return value @code{(hoot hoot)}. The @code{--run} flag is a handy way to quickly compile and test a small, simple program. Now, let's take a look at how to use Hoot programmatically from the Guile REPL. Launch @command{guile}, import the @code{(hoot compile)} module and call the @code{compile} procedure. @lisp @verbatim scheme@(guile-user)> ,use (hoot compile) scheme@(guile-user)> (define wasm (compile '(list 'hoot 'hoot) #:imports '((scheme base)))) @end verbatim @end lisp The result is a Wasm module. There is a lot of stuff inside, but we're not going to focus on that right now. We should load and run the module to verify that it outputs @code{(hoot hoot)} like we expect. We can do so from the comfort of our Guile REPL because Hoot includes a Wasm interpreter. There's no need to use a web browser or other Wasm runtime to try out small programs. First, import the @code{(hoot reflect)} module. Then, instantiate the Wasm module to boot up the interpreter: @lisp @verbatim scheme@(guile-user)> ,use (hoot reflect) scheme@(guile-user)> (define instance (hoot-instantiate wasm)) @end verbatim @end lisp All that's left to do now is execute the program with @code{hoot-load}: @lisp @verbatim scheme@(guile-user)> (hoot-load instance) $1 = # @end verbatim @end lisp Ta-da! It feels kind of funny to compile a Scheme program to Wasm only to load it back into Scheme, but it's a quick and easy way to test things out. For cases when you simply want to compile an expression and see the result immediately, there is a faster method. Just use the @code{compile-value} procedure instead: @lisp @verbatim scheme@(guile-user)> (compile-value '(list 1 2 3)) $2 = # @end verbatim @end lisp With @code{compile-value}, the compiled Wasm module is thrown away, which is just fine for testing throwaway code. Lists are cool but it would be a shame if we didn't talk about compiling something a little more complicated. Let's compile a simple, tail-recursive procedure! How about good ol' factorial? @lisp @verbatim scheme@(guile-user)> (define hoot-factorial (compile-value '(let () (define (factorial x result) (if (= x 1) result (factorial (- x 1) (* result x)))) factorial))) @end verbatim @end lisp A Hoot procedure can be called just like a regular procedure: @lisp @verbatim scheme@(guile-user)> (hoot-factorial 5 1) $3 = 120 @end verbatim @end lisp The Hoot reflection in Guile is great for quickly iterating on code, but what we really want is to get our programs running in a web browser. We've compiled a couple of things to Wasm now, but the resulting modules have stayed within the confines of Hoot's Wasm interpreter. To make something that can be loaded by a web browser, we need to create a Wasm binary. First, create a new directory for this tutorial: @example mkdir hoot-tutorial cd hoot-tutorial @end example Then, write the following trivial program to @file{hello.scm}: @lisp "Hello, world!" @end lisp Compile it and generate a bundle with all the necessary runtime libraries: @example guild compile-wasm --bundle -o hello.wasm hello.scm @end example To run @file{hello.wasm}, we need to write a small JavaScript program to boot it up. Let's call this @file{hello.js}: @example @verbatim async function load() { const [message] = await Scheme.load_main("hello.wasm"); console.log(message); } window.addEventListener("load", load); @end verbatim @end example We also need a minimal @file{index.html} web page to bring it all together: @example Guile is a hoot! @end example The file tree in @file{hoot-tutorial} should look like this: @example ./hello.js ./hello.scm ./hello.wasm ./index.html ./reflect.js ./reflect.wasm ./wtf8.wasm @end example Finally, we need a local web server to serve the files. Fortunately, Hoot includes a simple web server for development purposes. Start the web server like so: @example @verbatim guile -c '((@ (hoot web-server) serve))' @end verbatim @end example Visit @url{http://localhost:8088} in your web browser. You should see the text ``Hello, world!'' printed in the developer console. We hope this tutorial has helped you get started with Hoot! Read on for full API documentation. @node Compilation @chapter Compilation In Guile's compiler tower, Scheme code goes through several transformations before being compiled to VM bytecode. Scheme is lowered to @inlinefmtifelse{html, @url{https://www.gnu.org/software/guile/manual/html_node/Tree_002dIL.html, Tree-IL}, @ref{Tree-IL,,,Guile Reference}}, which is then lowered to @inlinefmtifelse{html, @url{https://www.gnu.org/software/guile/manual/html_node/Continuation_002dPassing-Style.html, Continuation-passing style}, @ref{Continuation-Passing Style,,,Guile Reference}}(CPS), and then finally to @inlinefmtifelse{html, @url{https://www.gnu.org/software/guile/manual/html_node/Bytecode.html, Bytecode}, @ref{Bytecode,,,Guile Reference}}. Hoot adds an additional backend that compiles the CPS intermediate representation to Wasm. In contrast to Guile's separate compilation approach where each module is compiled individually (with the possibility of some cross-module inlining), Hoot is a @emph{whole-program} compiler. The user program and all imported modules are part of the same compilation unit and the result is a single Wasm binary. Hoot tries to make this binary as small as possible to minimize bandwidth usage when deployed to the web. To do this, Hoot uses a ``tree shaking'' approach to remove all code is unused in a program. Making a small change to a program and recompiling will recompile @emph{the entire program}. Expect longer compilation times than you are used to with Guile. @menu * Compiling from the command line:: Compiling from the shell. * Compiling from Guile:: Compiling from Scheme. * Compilation REPL commands:: REPL shorthands. @end menu @node Compiling from the command line @section Compiling from the command line Hoot extends Guile's @command{guild} tool with a new subcommand: @command{compile-wasm}. The general syntax is: @example guild compile-wasm [@var{options}] @var{file} @end example Below is a basic example that compiles @file{foo.scm} to @file{foo.wasm} and allows access to third-party Scheme modules in the current directory: @example guild compile-wasm --load-path=. --output=foo.wasm foo.scm @end example The available options are documented below. @table @code @item --load-path=@var{dir} @itemx -L @var{dir} Add @var{dir} to the front of Hoot's module load path. The directories are searched in the order given on the command line and before any directories in the @env{HOOT_LOAD_PATH} environment variable. Note that this flag does @emph{not} modify Guile's load path. @item --output=@var{out-file} @itemx -o @var{out-file} Write output to @var{out-file}. @item --bundle @itemx --bundle=@var{dir} @itemx -b @var{dir} When combined with @code{-o}, copy the web runtime libraries to @var{dir} or the directory of @var{out-file} (from @code{-o}) if @var{dir} is not specified. @item -x @var{extension} Add @var{extension} to the set of source file extensions. @item --warn=@var{warning} @itemx -W @var{warning} Emit warnings of type @var{warning}; use @code{--warn=help} for a list of available warnings. @item --optimize=@var{opt} @itemx -O @var{opt} Specify optimization passes to run; use @code{-Ohelp} for a list of available optimizations @item --mode=@var{mode} Compile the Wasm in @var{mode}. Available modes are: @table @code @item primary Compile a main module: one which defines runtime facilities and which by default makes them available to secondary modules. This is the default mode. @item standalone Like @code{primary}, but without the possibility of sharing runtime facilities with secondary modules. @item secondary Compile an auxiliary module: one which imports runtime facilities instead of defining and exporting them. @end table @item --run @itemx --run=@var{js} Run the compiled Wasm; by default, in the Hoot virtual machine, otherwise using @var{js}, a JavaScript shell such as NodeJS. Useful for quickly testing out small programs. Consider this example program, @file{example.scm}: @lisp (use-modules) ; use default Guile environment (map 1+ '(1 2 3 4 5)) @end lisp To compile and run the above program on the Hoot VM, discarding the Wasm at the end, run: @example guild compile-wasm --run example.scm @end example To do the same with NodeJS, run: @example guild compile-wasm --run=node example.scm # => 42 @end example The above example assumes that @command{node} is on @code{$PATH} so adjust accordingly if that is not the case for your NodeJS installation. @item --async When combined with @code{--run}, run program in async context. Consider this example program, @file{example.scm}: @lisp (use-modules (fibers promises) (fibers timers)) (lambda (resolve reject) (call-with-async-result resolve reject (lambda () (sleep 1) 42))) @end lisp Without the @code{--async} flag, the result of running the above program would be the procedure described by the @code{lambda} form and nothing would happen. When run in async mode, the runtime will wait until the program resolves successfully with some return values or is rejected due to an error. @example guild compile-wasm --run --async example.scm # => (42) @end example @item --user-imports=@var{import-file} When combined with @code{--run}, load the Scheme/JavaScript (depending upon @code{--run}) source @var{import-file} and pass the result as additional imports when instantiating the Wasm module. On the Hoot VM, the file should evaluate to a 2-tier association list of imports. For example: @lisp (use-modules (rnrs bytevectors)) `(("uint8Array" . (("new" . ,make-bytevector) ("length" . ,bytevector-length) ("ref" . ,bytevector-u8-ref) ("set" . ,bytevector-u8-set!)))) @end lisp On JavaScript, the file should define a 2-tier object of imports. For JavaScript runtimes that support module imports via @code{require}, like NodeJS, the imports above could be translated like this: @example @verbatim exports.user_imports = { uint8Array: { new: (length) => new Uint8Array(length), length: (array) => array.length, ref: (array, index) => array[index], set: (array, index, value) => array[index] = value } }; @end verbatim @end example @item --dump-tree-il Print a debugging representation of the high-level expanded and optimized Scheme code. @item --dump-cps Print a debugging representation of the low-level CPS code, before generating WebAssembly. @item --dump-wasm Print a debugging representation of the generated WebAssembly code. @item --emit-names Emit a WebAssembly name section for debugging. For example, this allows browser developer tools to show human-readable Wasm function and type names. @end table The following environment variables are supported: @table @code @item HOOT_LOAD_PATH @vindex HOOT_LOAD_PATH This variable may be used to augment the path that is searched for Scheme module source code. Its value should be a colon-separated list of directories. @example $ export HOOT_LOAD_PATH="/path/to/modules:/some/other/modules" $ guild compile-wasm -o example.wasm example.scm @end example @end table @node Compiling from Guile @section Compiling from Guile Like Guile's built-in compiler, the Hoot compiler can also be invoked from Scheme. The @code{(hoot compile)} module provides the interface to the Wasm compiler backend. @deffn {Procedure} compile exp [#:import-abi? #f] [#:export-abi? #t] @ [#:imports %default-program-imports] @ [#:include-file %include-from-path] @ [#:extend-load-library (lambda (f) f)] @ [#:load-library (extend-load-library (builtin-module-loader import-abi?))] @ [#:optimization-level (default-optimization-level)] @ [#:warning-level (default-warning-level)] @ [#:dump-cps? #f] [#:dump-wasm? #f] [#:emit-names? #f] @ [#:opts '()] Compile the Scheme expression @var{exp} to Wasm and return a Wasm module. The environment in which @var{exp} is evaluated is defined by @var{imports}, a list of module names such as @code{(scheme time)} or @code{(hoot ffi)}. If not specified, a default list of imports will be used. When @var{import-abi?} is @code{#t}, the Wasm module will be built such that it needs to import its ABI from another module. When @var{export-abi?} is @code{#t}, the Wasm module will be built such that it exports its ABI functions. A typical use of these flags is to export the ABI from one ``main'' module and then import that ABI into any additional modules that are being used. When @var{emit-names?} is @code{#t} then human-readable names will be embedded in the resulting Wasm object. By default, this is turned off as it greatly increases binary size. Associating module names with source code is handled by @var{load-library}, a procedure that receives the module name as its only argument and returns the source code as an s-expression, or @code{#f} if there is no such module. The default loader is capable of loading modules from Hoot's standard library. It is generally recommended to leave @var{load-library} alone and use the default. To load additional modules, specify @var{extend-load-library} instead. @var{extend-load-library} is a procedure that receives one argument, @var{load-library}, and returns a procedure with the same signature as @var{load-library}. Through this extension mechanism, users can load their own modules. Most of the time, loading user modules from the file system is all that is needed. Hoot has a built-in @code{library-load-path-extension} extension procedure for this purpose. To demonstrate, let's first assume that the code below is saved to @file{example.scm} in the current directory: @lisp (library (example) (export double) (import (scheme base)) (define (double x) (* x 2))) @end lisp The compiler can then be extended to load modules from the current directory like so: @lisp (compile '(double 42) #:imports '((scheme base) (example)) #:extend-load-library (library-load-path-extension '("."))) @end lisp @inlinefmtifelse{html, @url{https://www.gnu.org/software/guile/manual/html_node/Compilation.html, See the Guile manual}, @xref{Compiling Scheme Code,,,Guile Reference}} for more information about invoking Guile's compiler. @end deffn @deffn {Procedure} read-and-compile port [#:import-abi? #f] [#:export-abi? #t] @ [#:include-file %include-from-path] @ [#:extend-load-library (lambda (f) f)] @ [#:load-library (extend-load-library (builtin-module-loader import-abi?))] @ [#:optimization-level (default-optimization-level)] @ [#:warning-level (default-warning-level)] @ [#:dump-cps? #f] [#:dump-wasm? #f] [#:emit-names? #f] @ [#:opts '()] Like @code{compile}, but read Scheme expressions from @var{port}. If the first expression is an @code{import} form, then only the bindings from those modules will be imported into the compilation unit. If the @code{import} form is omitted, a default set of modules will be imported. It is highly recommended to be explicit and use @code{import}. @end deffn @deffn {Procedure} compile-file input-file [#:import-abi? #f] [#:export-abi? #t] @ [#:include-file %include-from-path] @ [#:extend-load-library (lambda (f) f)] @ [#:load-library (extend-load-library (builtin-module-loader import-abi?))] @ [#:optimization-level (default-optimization-level)] @ [#:warning-level (default-warning-level)] @ [#:dump-cps? #f] [#:dump-wasm? #f] [#:emit-names? #f] @ [#:opts '()] Like @code{read-and-compile}, but read the Scheme expression from @var{input-file}. @end deffn @node Compilation REPL commands @section Compilation REPL commands The @code{(hoot repl)} module provides some REPL meta commands to make it easy to compile Scheme programs and run them in Hoot's Wasm interpreter. @deffn {REPL Command} hoot-compile exp [opts ...] Compile @var{exp} and return a Wasm module. @var{opts} may specify the keyword arguments to pass to the @code{compile} procedure (@pxref{Compiling from Guile}). @end deffn @deffn {REPL Command} hoot-compile-file file [opts ...] Compile the source code in @var{file} and return a Wasm module. @var{opts} may specify the keyword arguments to pass to the @code{compile-file} procedure (@pxref{Compiling from Guile}). @end deffn @deffn {REPL Command} hoot-run exp [opts ...] Compile and run @var{exp} and return the results. @end deffn @deffn {REPL Command} hoot-run-file file [opts ...] Compile and run the source code in @var{file} and return the results. @end deffn @node Reflection @chapter Reflection Hoot programs are guests that run inside some host system. Currently, Hoot can be used from JavaScript runtimes (like web browsers and NodeJS) and the Guile virtual machine (Scheme in your Scheme). In order to boot up a Hoot binary and inspect Scheme values within, we must reflect. Hoot provides both JavaScript and Scheme reflection interfaces. @menu * JavaScript reflection:: Interacting with Hoot from JavaScript. * Guile reflection:: Interacting with Hoot from Guile. @end menu @node JavaScript reflection @section JavaScript reflection The @code{Scheme} class is used to load a Hoot binary, start the program, and initialize reflection. @deftp {Class} Scheme A Scheme runtime environment. @end deftp @defop {Static method} Scheme load_main source [abi] [reflect_wasm_dir "."] [user_imports @{@}] Fetch and execute the Hoot Wasm binary at the URL @var{source} and return an array of Scheme values produced by the program. Alternatively, @var{source} may be a typed array or @code{ArrayBuffer} containing the Wasm binary data. The reflection library requires the assistance of some Wasm helper modules, which are looked up in @var{reflect_wasm_dir}. The @var{abi} parameter is for more advanced usage where multiple Hoot binaries share a single application binary interface (ABI). This should be set to @code{@{@}} when loading the first Scheme binary. It is better to use the @code{load_extension} method for subsequent binaries, though. The @var{user_imports} parameter is for providing concrete implementations of functions declared using the @ref{Foreign function interface}. It uses a two-tier nested object structure to map import names to the functions that implement them. For example, this Scheme code: @lisp (define-foreign make-text-node "document" "createTextNode" (ref string) -> (ref null extern)) @end lisp Could be instantiated like so: @example @verbatim Scheme.load_main("hello.wasm", { user_imports: { document: { createTextNode: Document.prototype.createTextNode.bind(document) } } }); @end verbatim @end example @end defop @defmethod Scheme load_extension path [user_imports @code{@{@}}] Fetch and load an additional Hoot binary at the URL @var{path} that shares the ABI of @code{this}. Optionally, a set of user-defined imported functions can be specified with the @var{user_imports} parameter. @end defmethod All of the fundamental Scheme types have an associated JavaScript class that can reflect their values. Calling the @code{repr} function on an instance of a reflected Scheme object will return a Scheme-like printing of the object. @example repr(pair) // => "(1 . 2)" @end example @deftp {Class} Char A Unicode character. @end deftp @deftp {Class} Eof End-of-file object. @end deftp @deftp {Class} Null The empty list. @end deftp @deftp {Class} Unspecified The unspecified value. @end deftp @deftp {Class} Complex real imag Complex number with real part @var{real} and imaginary part @var{imag}. @end deftp @deftp {Class} Fraction num denom An exact fraction with numerator @var{num} and denominator @var{denom}. @end deftp The @code{HeapObject} class is the parent class of all of the remaining Scheme types. @deftp {Class} HeapObject A Scheme heap object. @end deftp @defivar HeapObject reflector The reflector for @code{this}, an instance of the @code{Scheme} class. @end defivar The @code{reflector} property can be used in conjuction with the @code{load_extension} method to load additional Hoot binaries that share the same ABI. @example heapObject.reflector.load_extension("/helper.wasm") @end example @deftp {Class} Procedure A Scheme procedure. @end deftp Procedure instances can be invoked with the @code{call} method to perform a Javascript to Scheme function call. @defmethod Procedure call args@dots{} Call procedure with @var{args} and return an array of result values. @end defmethod @defmethod Procedure call_async args@dots{} Call procedure with @var{args} in an async context and return a promise to an array of result values. Before the procedure is called, @var{args} is prepended with two additional arguments: a function that resolves the promise, and a function that rejects the promise. It is up to the underlying Scheme procedure to use these values appropriately to settle the promise. @end defmethod @deftp {Class} Pair An immutable cons cell. @end deftp @deftp {Class} MutablePair A mutable cons cell. @end deftp @deftp {Class} Vector An immutable vector. @end deftp @deftp {Class} MutableVector A mutable vector. @end deftp @deftp {Class} Bytevector An immutable bytevector. @end deftp @deftp {Class} MutableBytevector A mutable bytevector. @end deftp @deftp {Class} Bitvector An immutable bitvector. @end deftp @deftp {Class} MutableBitvector A mutable bitvector. @end deftp @deftp {Class} MutableString A mutable string. @end deftp @deftp {Class} Sym A symbol. @end deftp @deftp {Class} Keyword A keyword. @end deftp @deftp {Class} Variable A mutable variable. @end deftp @deftp {Class} AtomicBox A mutable box with atomic updates. @end deftp @deftp {Class} HashTable A hash table. @end deftp @deftp {Class} WeakTable A weak key hash table. @end deftp @deftp {Class} Fluid A dynamic variable. @end deftp @deftp {Class} DynamicState A set of fluids. @end deftp @deftp {Class} Syntax A syntax object. @end deftp @deftp {Class} Port An I/O port. @end deftp @deftp {Class} Struct A user-defined structure. @end deftp @node Guile reflection @section Guile reflection The @code{(hoot reflect)} module provides an interface for inspecting and manipulating Scheme values that live within Wasm modules. This is the primary interface for testing compiler output directly from Guile. @deffn {Procedure} hoot-instantiate scheme-wasm [imports '()] [reflector] Instantiate and return a new Hoot module using the compiled Scheme Wasm module @var{scheme-wasm} and the reflection module @var{reflector}. If @var{reflector} is not specified, a new reflector instance will be created. Optionally, @var{imports} may contain a 2-tier association list structure of imported functions, globals, tables, and memories: @lisp `(("math" . (("random" . ,(lambda (x) (random x)))))) @end lisp @end deffn @deffn {Procedure} hoot-load module Invoke the load thunk of @var{module} and return the reflected result values. @end deffn The following procedures, @code{compile-value} and @code{compile-call}, are convenience procedures for when you just want to quickly compile something and see the result and you don't care about the intermediary Wasm binary. @deffn {Procedure} compile-value exp [imports %default-program-imports] @ [load-path '()] [wasm-imports '()] Compile @var{exp} and return the result. Optionally, @var{imports} may specify a list of Scheme module names to import. If unspecified, a default set of modules providing a basic Scheme environment will be imported. @var{load-path} is a list of file system directories to search for additional user modules. Optionally, @var{wasm-imports} may contain a 2-tier association list structure of imported Wasm functions, globals, tables, and memories. See @code{hoot-instantiate} for an example of such a structure. @end deffn @deffn {Procedure} compile-call proc-exp arg-exps ... @ [imports %default-program-imports] @ [load-path '()] [wasm-imports '()] Compile @var{proc-exp} and all @var{arg-exps}, call the procedure with the arguments, then return the results. See @code{compile-value} for an explanation of the keyword arguments. @end deffn @deffn {Procedure} hoot-module? obj Return @code{#t} if @var{obj} is a Hoot module. @end deffn @deffn {Procedure} hoot-module-reflector module Return the reflection module for @var{module}. @end deffn @deffn {Procedure} hoot-module-instance module Return the Wasm instance for @var{module}. @end deffn @deffn {Procedure} reflector? obj Return @code{#t} if @var{obj} is a reflector. @end deffn @deffn {Procedure} reflector-instance reflector Return the Wasm instance of @var{reflector}. @end deffn @deffn {Procedure} reflector-abi reflector Return the association list of ABI imports for @var{reflector}. @end deffn Below are the predicates and accessors for various Hoot heap types: @deffn {Procedure} hoot-object? obj Return @code{#t} if @var{obj} is a Hoot object. @end deffn @deffn {Procedure} hoot-complex? obj Return @code{#t} if @var{obj} is a Hoot complex number. @end deffn @deffn {Procedure} hoot-complex-real complex Return the real part of @var{complex}. @end deffn @deffn {Procedure} hoot-complex-imag complex Return the imaginary part of @var{complex}. @end deffn @deffn {Procedure} hoot-fraction? obj Return @code{#t} if @var{obj} is a Hoot fraction. @end deffn @deffn {Procedure} hoot-fraction-num fraction Return the numerator of @var{fraction} @end deffn @deffn {Procedure} hoot-fraction-denom fraction Return the denominator of @var{fraction}. @end deffn @deffn {Procedure} hoot-pair? obj Return @code{#t} if @var{obj} is a Hoot pair. @end deffn @deffn {Procedure} mutable-hoot-pair? obj Return @code{#t} if @var{obj} is a mutable Hoot pair. @end deffn @deffn {Procedure} hoot-pair-car pair Return the first element of @var{pair}. @end deffn @deffn {Procedure} hoot-pair-cdr pair Return the second element of @var{pair}. @end deffn @deffn {Procedure} hoot-vector? obj Return @code{#t} if @var{obj} is a Hoot vector. @end deffn @deffn {Procedure} mutable-hoot-vector? obj Return @code{#t} if @var{obj} is a mutable Hoot vector. @end deffn @deffn {Procedure} hoot-vector-length vec Return the length of @var{vec}. @end deffn @deffn {Procedure} hoot-vector-ref vec i Return the @var{i}th element of @var{vec}. @end deffn @deffn {Procedure} hoot-bytevector? obj Return @code{#t} if @var{obj} is a Hoot bytevector. @end deffn @deffn {Procedure} mutable-hoot-bytevector? obj Return @code{#t} if @var{obj} is a mutable Hoot bytevector. @end deffn @deffn {Procedure} hoot-bytevector-length bv Return the length of @var{bv}. @end deffn @deffn {Procedure} hoot-bytevector-ref bv i Return the @var{i}th byte of @var{bv}. @end deffn @deffn {Procedure} hoot-bitvector? obj Return @code{#t} if @var{obj} is a Hoot bitvector. @end deffn @deffn {Procedure} mutable-hoot-bitvector? obj Return @code{#t} if @var{obj} is a mutable Hoot bitvector. @end deffn @deffn {Procedure} hoot-bitvector-length bv Return the length of @var{bv}. @end deffn @deffn {Procedure} hoot-bitvector-ref bv i Return the @var{i}th bit of @var{bv}. @end deffn @deffn {Procedure} hoot-symbol? obj Return @code{#t} if @var{obj} is a Hoot symbol. @end deffn @deffn {Procedure} hoot-symbol-name sym Return the string name of @var{sym}. @end deffn @deffn {Procedure} hoot-keyword? obj Return @code{#t} if @var{obj} is a Hoot keyword. @end deffn @deffn {Procedure} hoot-keyword-name keyword Return the name string of @var{keyword}. @end deffn @deffn {Procedure} mutable-hoot-string? obj Return @code{#t} if @var{obj} is a mutable Hoot string. @end deffn @deffn {Procedure} mutable-hoot-string->string str Return the underlying string for @var{str}. @end deffn @deffn {Procedure} hoot-procedure? obj Return @code{#t} if @var{obj} is a Hoot procedure. @end deffn @deffn {Procedure} hoot-apply proc . args Apply the Hoot procedure @var{proc} with @var{args}. @end deffn @deffn {Procedure} hoot-apply-async proc . args Apply the Hoot procedure @var{proc} in an asynchronous context. @var{proc} should be a procedure that accepts two additional arguments (arguments 0 and 1) in addition to @var{args}: @itemize @item @code{resolved}: An opaque external value representing the successful completion of the async operation. @item @code{rejected}: An opaque external value representing the failure of the async operation. @end itemize You almost certainly want to be using this procedure with @code{call-with-async-result} in the @code{(fibers promises)} module. @end deffn @deffn {Procedure} hoot-variable? obj Return @code{#t} if @var{obj} is a Hoot variable. @end deffn @deffn {Procedure} hoot-atomic-box? obj Return @code{#t} if @var{obj} is a Hoot atomic box. @end deffn @deffn {Procedure} hoot-hash-table? obj Return @code{#t} if @var{obj} is a Hoot hash table. @end deffn @deffn {Procedure} hoot-weak-table? obj Return @code{#t} if @var{obj} is a Hoot weak table. @end deffn @deffn {Procedure} hoot-fluid? obj Return @code{#t} if @var{obj} is a Hoot fluid. @end deffn @deffn {Procedure} hoot-dynamic-state? obj Return @code{#t} if @var{obj} is a Hoot dynamic state. @end deffn @deffn {Procedure} hoot-syntax? obj Return @code{#t} if @var{obj} is a Hoot syntax object. @end deffn @deffn {Procedure} hoot-port? obj Return @code{#t} if @var{obj} is a Hoot port. @end deffn @deffn {Procedure} hoot-struct? obj Return @code{#t} if @var{obj} is a Hoot struct. @end deffn @node Deployment @chapter Deployment Hoot's primary deployment targets are JavaScript runtimes, web browsers in particular. Hoot binaries are compatible with all major web browsers: @itemize @item Mozilla Firefox as of version 121 @item Google Chrome as of version 119 @item Safari as of version 18.2 @end itemize Additionally, Hoot binaries can also run in server-side JavaScript runtimes that are derived from the JavaScript engines within web browsers, such as NodeJS which is based on Google's V8 runtime. At this time, it is @emph{not possible} to run Hoot binaries on non-JavaScript Wasm runtimes such as Wasmtime. If you're feeling adventurous and manage to figure out how to deploy to Wasmtime or a similar runtime, please let us know! @menu * Web deployment:: Deploy to web browsers. * NodeJS deployment:: Deploy to NodeJS. @end menu @node Web deployment @section Web deployment On the client-side web, JavaScript is the host environment for Wasm modules and the @url{https://developer.mozilla.org/en-US/docs/WebAssembly,WebAssembly} API is used to load and run them. Hoot includes a JavaScript library, @file{reflect.js} (@pxref{JavaScript reflection}) that wraps the @code{WebAssembly} API and furthermore can inspect Scheme values and call Scheme procedures. This chapter documents deploying Hoot artifacts and using the reflection API to run Scheme in the browser. In order to run Hoot binaries in the browser, a web server needs to host a copy of the Hoot JavaScript runtime. The runtime files can be found in the @file{$prefix/share/guile-hoot/} directory, where @code{$prefix} is the directory where Hoot was installed on your system. This is typically @file{/usr} or @file{/usr/local} on Linux distributions such as Debian, Ubuntu, Fedora, etc. The runtime files can be copied to the current directory like this: @example cp $prefix/share/guile-hoot/$version/reflect-js/reflect.js . cp $prefix/share/guile-hoot/$version/reflect-wasm/*.wasm . @end example Don't forget to upload the Wasm files for the Scheme programs, too! A bit of JavaScript code is needed to bootstrap a Scheme program using the @file{reflect-js/reflect.js} library (@pxref{JavaScript reflection}). For example, here's an example @file{boot.js} file that runs the Scheme program @file{hello.wasm} and prints the return values: @example @verbatim window.addEventListener("load", async () => { const results = await Scheme.load_main("/hello.wasm"); console.log(results); }); @end verbatim @end example The @code{Scheme} namespace is defined in @file{reflect.js}. @xref{JavaScript reflection} for more information. To run @file{boot.js} on a web page, add @code{

Hello, Hoot!

@end example @node NodeJS deployment @section NodeJS deployment Deploying to @url{https://nodejs.org,NodeJS} is similar to web deployment but without all the web server setup. A small boot script is needed to import the @file{reflect.js} library (@pxref{JavaScript reflection}) and then load the Wasm binary. For example, here's a small boot script that imports @file{reflect.js}, calls @code{Scheme.load_main} to load the Wasm binary, imports the @code{document.findElementById} method, and prints the program output: @example @verbatim const hoot = await import("./reflect.js"); const results = await hoot.Scheme.load_main("example.wasm", { reflect_wasm_dir: ".", user_imports: { document: { findElementById: (id) => document.findElementById(id) } } }); console.log(results); @end verbatim @end example The necessary runtime files can be found in the @file{$prefix/share/guile-hoot/} directory, where @code{$prefix} is the directory where Hoot was installed on your system. This is typically @file{/usr} or @file{/usr/local} on Linux distributions such as Debian, Ubuntu, Fedora, etc. The runtime files can be copied to the current directory like this: @example cp $prefix/share/guile-hoot/$version/reflect-js/reflect.js . cp $prefix/share/guile-hoot/$version/reflect-wasm/*.wasm . @end example Once the necessary files are in place, running the program is simple: @example node boot.js @end example @node Scheme reference @chapter Scheme reference In addition to supporting standard Scheme features, Hoot includes many of its own extensions. This chapter documents the APIs of these extensions. @menu * Boxes:: Mutable cells that store a single object. * Atomics:: Atomic boxes. * Bitvectors:: Sequences of bits. * Bytevectors:: Sequences of bytes. * Control:: Delimited continuations. * Exceptions:: Error handling. * Fluids:: Dynamic state. * Parameters:: Dynamic variables. * Hashtables:: Mutable key/value data structures. * Records:: Extensions to standard records. * Pattern matching:: Object destructuring. * Foreign function interface:: Call host functions from Scheme. * Evaluation:: Interpret Scheme programs at runtime. * Fibers:: Lightweight concurrency. * Finalization:: Finalization registries. @end menu @node Boxes @section Boxes The @code{(hoot boxes)} module provides boxes, which are single-value, mutable cells. @deffn {Procedure} make-box init Return a new box with an initial stored value of @var{init}. @end deffn @deffn {Procedure} box-ref box Return the value stored within @var{box}. @end deffn @deffn {Procedure} box-set! box val Set the stored value of @var{box} to @var{val}. @end deffn @node Atomics @section Atomics The @code{(hoot atomics)} module provides an API compatible with Guile's @code{(ice-9 atomic)} module. Atomic operations allow for concurrent access to a resource form many threads without the need to use thread synchronization constructs like mutexes. Currently, WebAssembly assumes single-threaded execution, making atomicity trivial. See @inlinefmtifelse{html, @url{https://www.gnu.org/software/guile/manual/html_node/Atomics.html, the Guile manual}, @ref{Atomics,,,Guile Reference}} for more detailed information. @deffn {Procedure} make-atomic-box init Return a new atomic box with an initial stored value of @var{init}. @end deffn @deffn {Procedure} atomic-box-ref box Return the value stored within the atomic box @var{box}. @end deffn @deffn {Procedure} atomic-box-set! box val Store @var{val} into the atomic box @var{box}. @end deffn @deffn {Procedure} atomic-box-swap! box val Store @var{val} into the atomic box @var{box}, and return the value that was previously stored in the box. @end deffn @deffn {Procedure} atomic-box-compare-and-swap! box expected desired If the value of the atomic box @var{box} is the same as @var{expected} (in the sense of @code{eq?}), replace the contents of the box with @var{desired}. Otherwise, the box is not updated. Return the previous value of the box in either case. You can know if the swap worked by checking if the return value is @code{eq?} to @var{expected}. @end deffn @node Bitvectors @section Bitvectors The @code{(hoot bitvectors)} module provides bitvectors, which are tightly packed arrays of booleans. @deffn {Procedure} make-bitvector len [fill #f] Return a new bitvector of @var{len} bits with all bits initialized to @var{fill}. @end deffn @deffn {Procedure} bitvector? obj Return @code{#t} if @var{obj} is a bitvector. @end deffn @deffn {Procedure} bitvector-length bv Return the length of the bitvector @var{bv}. @end deffn @deffn {Procedure} bitvector-ref bv i Return the boolean value of bit @var{i} in the bitvector @var{bv}. @end deffn @deffn {Procedure} bitvector-set-bit! bv i Set the bit @var{i} in the bitvector @var{bv} to @code{#t}. @end deffn @node Bytevectors @section Bytevectors The @code{(hoot bytevectors)} module provides some of the R6RS bytevectors API. Bytevectors are sequences of bytes that are useful for low-level manipulation of binary data. @deffn {Procedure} make-bytevector len [init 0] Return a new bytevector of @var{len} bytes with all bytes initialized to @var{init}. @end deffn @deffn {Procedure} bytevector [byte ...] Return a new bytevector containing the sequence @var{byte} @dots{}. @end deffn @deffn {Procedure} bytevector? obj Return @code{#t} if @var{obj} is a bytevector. @end deffn @deffn {Procedure} bytevector-length bv Return the length of @var{bv} in bytes. @end deffn @deffn {Procedure} bytevector-copy bv [start 0] [end (bytevector-length bv)] Return a new bytevector that is a copy of the bytevector @var{bv} from byte index @var{start} to @var{end}. @var{start} must be less than or equal to @var{end}. @end deffn @deffn {Procedure} bytevector-copy! to at from [start 0] [end (bytevector-length from)] Copy the subsection of bytevector @var{from}, defined by the byte range [@var{start}, @var{end}), into the bytevector @var{from}. @end deffn @deffn {Procedure} bytevector-append [bv ...] Return a new bytevector that concatenates all the input bytevectors @var{bv} @dots{} in the order given. @end deffn @deffn {Procedure} bytevector-concatenate bvs Return a new bytevector that concatenates all of the bytevectors in the list @var{bvs}. @end deffn @deffn {Procedure} bytevector-concatenate-reverse bvs Return a new bytevector that concatenates all of the bytevectors in the list @var{bvs} in reverse order. @end deffn @deffn {Procedure} bytevector-u8-ref bv index @deffnx {Procedure} bytevector-s8-ref bv index @deffnx {Procedure} bytevector-u16-native-ref bv index @deffnx {Procedure} bytevector-s16-native-ref bv index @deffnx {Procedure} bytevector-u32-native-ref bv index @deffnx {Procedure} bytevector-s32-native-ref bv index @deffnx {Procedure} bytevector-u64-native-ref bv index @deffnx {Procedure} bytevector-s64-native-ref bv index Return the N-bit signed or unsigned integer from the bytevector @var{bv} at @var{index} using the host's native endianness. @end deffn @deffn {Procedure} bytevector-ieee-single-native-ref bv index @deffnx {Procedure} bytevector-ieee-double-native-ref bv index Return the single or double precision IEEE floating piont number from the bytevector @var{bv} at @var{index} using the host's native endianness. @end deffn @deffn {Procedure} bytevector-u8-set! bv index x @deffnx {Procedure} bytevector-s8-set! bv index x @deffnx {Procedure} bytevector-u16-native-set! bv index x @deffnx {Procedure} bytevector-s16-native-set! bv index x @deffnx {Procedure} bytevector-u32-native-set! bv index x @deffnx {Procedure} bytevector-s32-native-set! bv index x @deffnx {Procedure} bytevector-u64-native-set! bv index x @deffnx {Procedure} bytevector-s64-native-set! bv index x Store @var{x} as an N-bit signed or unsigned integer in the bytevector @var{bv} at @var{index} using the host's native endianness. @end deffn @deffn {Procedure} bytevector-ieee-single-native-set! bv index x @deffnx {Procedure} bytevector-ieee-double-native-set! bv index x Store @var{x} as a single or double precision IEEE floating piont number in the bytevector @var{bv} at @var{index} using the host's native endianness. @end deffn @node Control @section Control The @code{(hoot control)} module provides an interface for Guile's delimited continuation facility known as ``prompts'' and some of the @code{(ice-9 control)} API. See @inlinefmtifelse{html, @url{https://www.gnu.org/software/guile/manual/html_node/Prompts.html, the Guile manual}, @ref{Prompts,,,Guile Reference}} for more detailed information. @deffn {Procedure} make-prompt-tag [stem ``prompt''] Return a new prompt tag that incorporates the value of @var{stem}. A prompt tag is simply a unique object. @end deffn @deffn {Procedure} call-with-prompt tag body handler Call the procedure @var{body}, a procedure of 0 arguments or ``thunk'', within the context of a prompt marked with @var{tag}. Should this prompt be aborted via @code{abort-to-prompt}, the procedure @var{handler} is called. The @var{handler} procedure receives as arguments a continuation object and any additional arguments that were passed to @code{abort-to-prompt}. @end deffn @deffn {Procedure} abort-to-prompt tag [val ...] Unwind the dynamic and control context to the nearest prompt named @var{tag}, so passing the additional values @var{val} @dots{} @end deffn @deffn {Procedure} default-prompt-tag Return the default prompt tag. @end deffn @deffn {Procedure} default-prompt-handler Return the default prompt handler procedure. @end deffn Note that both @code{default-prompt-tag} and @code{default-prompt-handler} are parameters, so their values may be modified by using @code{parameterize}. @xref{Parameters} for more information. @deffn {Syntax} % expr @deffnx {Syntax} % expr handler @deffnx {Syntax} % tag expr handler Syntactic sugar for @code{call-with-prompt}. Evaluate @var{expr} in the context of a prompt. If @var{tag} is ommitted, the default prompt tag will be used. If @var{handler} is omitted, the default prompt handler will be used. @end deffn @node Exceptions @section Exceptions @node Exception types @subsection Exception types The @code{(hoot exceptions)} module implements Guile's exception API. See @inlinefmtifelse{html, @url{https://www.gnu.org/software/guile/manual/html_node/Exceptions.html, the Guile manual}, @ref{Exceptions,,,Guile Reference}} for more detailed information. @deffn {Procedure} make-exception exceptions @dots{} Return an exception object composed of @var{exceptions}. @end deffn @deffn {Procedure} exception? obj Return @code{#t} if @var{obj} is an exception object. @end deffn Below are the built-in exception types and their respective constructors, predicates, and accessors. @deftp {Exception Type} &exception @end deftp @deffn {Procedure} simple-exception? obj @end deffn @deftp {Exception Type} &compound-exception @end deftp @deffn {Procedure} make-compound-exception components @deffnx {Procedure} compound-exception? obj @deffnx {Procedure} compound-exception-components compound-exception @end deffn @deftp {Exception Type} &message @end deftp @deffn {Procedure} make-exception-with-message message @deffnx {Procedure} exception-with-message? obj @deffnx {Procedure} exception-message exception @end deffn @deftp {Exception Type} &warning @end deftp @deffn {Procedure} make-warning @deffnx {Procedure} warning? obj @end deffn @deftp {Exception Type} &serious @end deftp @deffn {Procedure} make-serious-exception @deffnx {Procedure} serious-exception? obj @end deffn @deftp {Exception Type} &error @end deftp @deffn {Procedure} make-error @deffnx {Procedure} error? obj @end deffn @deftp {Exception Type} &violation @end deftp @deffn {Procedure} make-violation @deffnx {Procedure} violation? obj @end deffn @deftp {Exception Type} &assertion @end deftp @deffn {Procedure} make-assertion-violation @deffnx {Procedure} assertion-violation? obj @end deffn @deftp {Exception Type} &arity-violation @end deftp @deffn {Procedure} make-arity-violation @deffnx {Procedure} arity-violation? obj @end deffn @deftp {Exception Type} &implementation-restriction @end deftp @deffn {Procedure} make-implementation-restriction-violation @deffnx {Procedure} implementation-restriction-violation? obj @end deffn @deftp {Exception Type} &failed-type-check @end deftp @deffn {Procedure} make-failed-type-check predicate @deffnx {Procedure} failed-type-check? obj @deffnx {Procedure} failed-type-check-predicate exception @end deffn @deftp {Exception Type} &non-continuable @end deftp @deffn {Procedure} make-non-continuable-violation @deffnx {Procedure} non-continuable-violation? obj @end deffn @deftp {Exception Type} &irritants @end deftp @deffn {Procedure} make-exception-with-irritants irritants @deffnx {Procedure} exception-with-irritants? obj @deffnx {Procedure} exception-irritants exception @end deffn @deftp {Exception Type} &origin @end deftp @deffn {Procedure} make-exception-with-origin origin @deffnx {Procedure} exception-with-origin? obj @deffnx {Procedure} exception-origin exception @end deffn @deftp {Exception Type} &lexical @end deftp @deffn {Procedure} make-lexical-violation @deffnx {Procedure} lexical-violation? obj @end deffn @deftp {Exception Type} &i/o @end deftp @deffn {Procedure} make-i/o-error @deffnx {Procedure} i/o-error? @end deffn @deftp {Exception Type} &i/o-line-and-column @end deftp @deffn {Procedure} make-i/o-line-and-column-error line column @deffnx {Procedure} i/o-line-and-column-error? obj @deffnx {Procedure} i/o-error-line exception @deffnx {Procedure} i/o-error-column exception @end deffn @deftp {Exception Type} &i/o-filename @end deftp @deffn {Procedure} make-i/o-filename-error filename @deffnx {Procedure} i/o-filename-error? obj @deffnx {Procedure} i/o-error-filename exception @end deffn @deftp {Exception Type} &i/o-not-seekable @end deftp @deffn {Procedure} make-i/o-not-seekable-error @deffnx {Procedure} i/o-not-seekable-error? obj @end deffn @deftp {Exception Type} &i/o-port @end deftp @deffn {Procedure} make-i/o-port-error port @deffnx {Procedure} i/o-port-error? obj @deffnx {Procedure} i/o-error-port exception @end deffn @node Raising and handling exceptions @subsection Raising and handling exceptions The @code{(hoot errors)} module provides procedures for raising and handling exceptions. @deffn {Procedure} raise exception Raise the non-continuable exception @var{exception} by invoking the current exception handler. @end deffn @deffn {Procedure} raise-continuable exception Raise the continuable exception @var{exception} by invoking the current exception handler. @end deffn @deffn {Procedure} raise-exception exception [#:continuable? #f] Raise the exception @var{exception} by invoking the current exception handler. When @var{continuable?} is @code{#t}, the raised exception is continuable. @end deffn @deffn {Procedure} with-exception-handler handler thunk [#:unwind? #f] Call @var{thunk}, a procedure of zero arguments, in a context where @var{handler}, a procedure of one argument, is the current exception handler. If an exception is raised then @var{handler} will be called with the exception obect. When @var{unwind?} is @code{#t}, the stack will be unwound before @var{handler} is called. The default behavior is not to unwind. When the stack is not unwound, it is up to @var{handler} to properly manage control flow. Control is allowed to fallthrough @var{handler} and resume from where the exception was raised only if the raised exception is @emph{continuable}. For non-continuable exceptions, @var{handler} should abort to some prompt (@xref{Control}) to escape the exception handling context. @end deffn @node Fluids @section Fluids A fluid is a variable whose value is associated with the dynamic extent of a procedure call. The @code{(hoot fluids)} module implements Guile's fluid API. See @inlinefmtifelse{html, @url{https://www.gnu.org/software/guile/manual/html_node/Fluids-and-Dynamic-States.html, the Guile manual}, @ref{Fluids and Dynamic States,,,Guile Reference}} for more detailed information. @deffn {Procedure} make-fluid [default #f] Return a new fluid whose initial value is @var{default}. @end deffn @deffn {Procedure} fluid? obj Return @code{#t} if @var{obj} is a fluid. @end deffn @deffn {Procedure} fluid-ref fluid Return the value currently stored within @var{fluid}. @end deffn @deffn {Procedure} fluid-set! fluid val Set the contents of @var{fluid} to @var{val}. @end deffn @deffn {Procedure} with-fluid* fluid val thunk Call @var{thunk}, a procedure of zero arguments, in a context where the @var{fluid} is set to @var{val}. When control leaves the dynamic extent of @var{thunk}, @var{fluid} is set back to its previous value. @end deffn @deffn {Syntax} with-fluids ((fluid value) ...) body1 body2 ... Evaluate @var{body1} @var{body2} @dots{} in a context where each @var{fluid} is set to its respective @var{value}. @end deffn @node Parameters @section Parameters Parameters are Guile's facility for dynamically bound variables. While parameters are part of the default Guile environment, in Hoot they are provided by the @code{(hoot parameters)} module. See @inlinefmtifelse{html, @url{https://www.gnu.org/software/guile/manual/html_node/Parameters.html, the Guile manual}, @ref{Parameters,,,Guile Reference}} for more detailed information. A parameter is a procedure. To retrieve the value of a parameter, call it with zero arguments. To set a new value, call it with one argument. @lisp (define counter (make-parameter 0)) (counter) ; => 0 (counter 1) (counter) ; => 1 (parameterize ((counter 2)) (counter)) ; => 2 (counter) ; => 1 @end lisp @deffn {Procedure} make-parameter init [conv (lambda (x) x)] Return a new parameter whose initial value is @var{(conv init)}. @var{conv} is a procedure of one argument that transforms an incoming value into the value that is actually stored within the parameter. The default @var{conv} is an identity function that applies no transformation at all. @end deffn @deffn {Syntax} parameterize ((parameter value) ...) body1 body2 ... Evaluate @var{body1} @var{body2} @dots{} in a context where each @var{parameter} is set to its respective @var{value}. When control leaves the dynamic extent of the body, each @var{parameter} is set back to its previous value. @end deffn @node Hashtables @section Hashtables There are many mutable hashtable APIs amongst all the various Scheme implementations, standards, and SRFIs. From our point of view, there is no clear ``best'' hashtable API that has emerged, but we think the R6RS interface is OK. Guile's own hashtable API has design issues that are best left in the past. So, the @code{(hoot hashtables)} module is R6RS-like but with some notable differences. @deffn {Procedure} make-hashtable [hash hash] [equiv equal?] Return a new, empty hashtable that uses the hash procedure @var{hash} and equivalence procedure @var{equiv}. @end deffn @deffn {Procedure} make-eq-hashtable Return a new, empty hashtable that uses @code{eq?} as the equivalence function and hashes keys accordingly. @end deffn @deffn {Procedure} make-eqv-hashtable Return a new, empty hashtable that uses @code{eqv?} as the equivalence function and hashes keys accordingly. @end deffn @deffn {Procedure} hashtable? obj Return @code{#t} if @var{obj} @end deffn @deffn {Procedure} hashtable-hash table Return the hash function for @var{table}. @end deffn @deffn {Procedure} hashtable-equiv table Return the equivalence function for @var{table}. @end deffn @deffn {Procedure} hashtable-size table Return the current number of key/value pairs in @var{table}. @end deffn @deffn {Procedure} hashtable-ref table key [default #f] Return the value associated with @var{key} in @var{table}, or @var{default} if there is no such association. @end deffn @deffn {Procedure} hashtable-set! table key value Associate @var{val} with @var{key} in @var{table}, potentially overwriting any previous association with @var{key}. @end deffn @deffn {Procedure} hashtable-delete! table key Remove the association with @var{key} in @var{table}, if one exists. @end deffn @deffn {Procedure} hashtable-clear! table Remove all of the key/value associations in @var{table}. @end deffn @deffn {Procedure} hashtable-contains? table key Return @code{#t} if @var{key} has an associated value in @var{table}. @end deffn @deffn {Procedure} hashtable-copy table Return a copy of @var{table}. @end deffn @deffn {Procedure} hashtable-keys table Return a list of keys in @var{table}. @end deffn @deffn {Procedure} hashtable-values table Return a list of values in @var{table}. @end deffn @deffn {Procedure} hashtable-for-each proc table Apply @var{proc} to each key/value association in @var{table}. Each call is of the form @code{(proc key value)}. @end deffn @deffn {Procedure} hashtable-fold proc init table Accumulate a result by applying @var{proc} with each key/value association in @var{table} and the result of the previous @var{proc} call. Each call is of the form @code{(proc key value prev)}. For the first call, @code{prev} is the initial value @var{init}. @end deffn Hoot also includes weak key hash tables that wrap those of the Wasm host platform, such as the @code{WeakMap} JavaScript class on the web. @deffn {Procedure} make-weak-key-hashtable Return a new weak key hashtable. @end deffn @deffn {Procedure} weak-key-hashtable? obj Return @code{#t} if @var{obj} is a weak key hashtable. @end deffn @deffn {Procedure} weak-key-hashtable-ref hashtable key [default #f] Return the value associated with @var{key} in @var{hashtable} or @var{default} if there is no such association. @end deffn @deffn {Procedure} weak-key-hashtable-set! hashtable key value Modify @var{hashtable} to associate @var{key} with @var{value}, overwriting any previous association that may have existed. @end deffn @deffn {Procedure} weak-key-hashtable-delete! hashtable key Remove the association with @var{key} in @var{hashtable}, if one exists. @end deffn The following hash functions are available: @deffn {Procedure} hash key size @deffnx {Procedure} hashq key size @deffnx {Procedure} hashv key size Return a hash value for @var{key} suitable for using in a table containing @var{size} buckets. The returned hash value will be in the range [0, @var{size}). @code{hashq} is the hash function used by @code{make-eq-hashtable}, and @code{hashv} is used by @code{make-eqv-hashtable}. @end deffn @node Records @section Records The @code{(hoot records)} module extends the R7RS @code{define-record-type} form with additional features such as inheritance and opaque types. @deffn {Syntax} define-record-type name @ [#:printer] [#:parent] [#:uid] [#:extensible? #t] [#:opaque? #f] @ [#:allow-duplicate-field-names? #f] @ constructor predicate @ (field field-ref [field-set]) ... Define a new record type descriptor bound to @var{name}. Define a constructor procedure bound to @var{constructor} and a predicate procedure bound to @var{predicate}. For each @var{field}, define an accessor procedure @var{field-ref} and, optionally, a modifier procedure @var{field-set}. The record type will inherit from the record type descriptor bound to @var{parent}, as long as @var{parent} is extensible. By default, record types are extensible. A record type may be marked as ``final'' by passing an @var{extensible?} flag of @code{#f}. When @var{opaque?} is @code{#t}, instances of this record type will be compared for equality by identity @emph{only}. This means that @code{(equal? a b)} only returns @code{#t} when @code{a} and @code{b} reference the same instance of the record type. In other words, they must be @code{eq?}. The default behavior is to perform deep structural equality checking by comparing record fields. When @var{printer} is specified, that procedure will be used when printing instances of this record type rather than the default printer. @var{uid} should be a unique identifier that will be associated with the record type when specified. Record types have no unique id by default. When @var{allow-duplicate-field-names?} is @code{#t}, field names may appear more than once in the fields section. @end deffn @c @subsection Applicable records @c Hoot's record type system can be used to create new types that can be @c applied as if they were regular procedures. These are known as @c @emph{applicable records}. The @code{} type defines @c a single field that should contain a procedure. Any record type that @c descends from the @code{} lineage (via @c @code{#:parent}) becomes procedure-like. @c As a contrived example, an incrementing counter could be implemented @c like this: @c @lisp @c (use-modules (hoot records)) @c (define-record-type @c #:parent @c (%make-counter procedure count) @c counter? @c (count counter-count set-counter-count!)) @c (define (make-counter) @c (define (next!) @c (let ((x (1+ (counter-count counter)))) @c (set-counter-count! counter x) @c x)) @c (define counter (%make-counter next! 0)) @c counter) @c (define c (make-counter)) @c (counter? c) ;; => #t @c (procedure? c) ;; => #t @c (c) ;; => 1 @c (c) ;; => 2 @c @end lisp @c Note that @code{} objects are recognized as both counters @c @emph{and} procedures! @c @defvr {Variable} @c The record type descriptor for applicable records. @c @end defvr @c @deffn {Procedure} applicable-record? obj @c Return @code{#t} if @var{obj} is an applicable record. @c @end deffn @c @deffn {Procedure} applicable-record-procedure obj @c Return the procedure stored within the applicable record @var{obj}. @c @end deffn @c @deffn {Procedure} set-applicable-record-procedure! obj proc @c Set the procedure stored within the applicable record @var{obj} to @c @var{proc}. @c @end deffn @node Pattern matching @section Pattern matching Hoot provides a port of Guile's @code{(ice-9 match)} module for pattern matching. See @inlinefmtifelse{html, @url{https://www.gnu.org/software/guile/manual/html_node/Pattern-Matching.html, Pattern Matching} in the Guile manual, @ref{Pattern Matching,,, guile, GNU Guile Reference Manual}} for more information. @node Foreign function interface @section Foreign function interface WebAssembly follows the capability security model, which means that modules cannot do much on their own. Wasm modules are guests within a host. They must be given capabilities by the host in order to interact with the outside world. Modules request capabilities by declaring imports, which the host then fills out with concrete implementations at instantiation time. Hoot provides a foreign function interface (FFI) in the @code{(hoot ffi)} module to embed these import declarations within Scheme code. The @code{define-foreign} form declares an import with a given type signature (Wasm is statically typed) and defines a procedure for calling it. The FFI takes care of converting Scheme values to Wasm values and vice versa. For example, declaring an import for creating text nodes in a web browser could look like this: @lisp (define-foreign make-text-node "document" "createTextNode" (ref string) -> (ref extern)) @end lisp In the above example, the procedure is bound to the variable @code{make-text-node}. In the Wasm binary, this import is named ``createTextNode'' and resides in the ``document'' namespace of the import table. A Wasm host is expected to satisfy this import by providing a function that accepts one argument, a string, and returns an arbitary host value which may be null. Note that declaring an import @emph{does not} do anything to bind that import to an implementation on the host. The Wasm guest cannot grant capabilities unto itself. Furthermore, the host could be any Wasm runtime, so the actual implementation will vary. In the context of a web browser, the JavaScript code that instantiates a module with this import could look like this: @example @verbatim Scheme.load_main("hello.wasm", {}, { document: { createTextNode: (text) => document.createTextNode(text) } }); @end verbatim @end example And here's what it might look like when using the Hoot interpreter: @lisp (use-modules (hoot reflect)) (hoot-instantiate (call-with-input-file "hello.wasm" parse-wasm) `(("document" . (("createTextNode" . ,(lambda (str) `(text ,str))))))) @end lisp Once defined, @code{make-text-node} can be called like any other procedure: @lisp (define hello (make-text-node "Hello, world!")) @end lisp Since the return type of @code{make-text-node} is @code{(ref extern}), the value of @code{hello} is an @emph{external reference}. To check if a value is an external reference, use the @code{external?} predicate: @lisp (external? hello) ; => #t @end lisp External references may be null, which could indicate failure, a cache miss, etc. To check if an external value is null, use the @code{external-null?} predicate: @lisp (external-null? hello) ; => #f @end lisp Note that we defined the return type of @code{make-text-node} to be @code{(ref extern)}, not @code{(ref null extern)}, so @code{hello} would never be null in this example. A large application will likely need to manipulate many different kinds of foreign values. This introduces an opportunity for errors because @code{external?} cannot distinguish between them. The solution is to wrap external values using disjoint types. To define such wrapper types, use @code{define-external-type}: @lisp (define-external-type text-node? wrap-text-node unwrap-text-node) @end lisp @code{make-text-node} could then be reimplemented like this: @lisp (define-foreign %make-text-node "document" "createTextNode" (ref string) -> (ref extern)) (define (make-text-node str) (wrap-text-node (%make-text-node str))) (define hello (make-text-node "Hello, world!")) (external? hello) ; => #f (text-node? hello) ; => #t (external? (unwrap-text-node hello)) ; => #t @end lisp We've now explained the basics of using the FFI. Read below for detailed API documentation. @deffn {Syntax} define-foreign scheme-name namespace import-name param-types ... -> result-type Define @var{scheme-name}, a procedure wrapping the Wasm import @var{import-name} in the namespace @var{namespace}. The signature of the function is specified by @var{param-types} and @var{result-type}, which are all Wasm types expressed in WAT form. Valid parameter types are: @itemize @item i32: 32-bit integer @item i64: 64-bit integer @item f32: 32-bit float @item f64: 64-bit float @item (ref string): a string @item (ref extern): a non-null external value @item (ref null extern): a possibly null external value @item (ref eq): any Scheme value @end itemize Valid result types are: @itemize @item none: no return value @item i32: 32-bit integer @item i64: 64-bit integer @item f32: 32-bit float @item f64: 64-bit float @item (ref string): a string @item (ref null string): a possibly null string @item (ref extern): a non-null external value @item (ref null extern): a possibly null external value @item (ref eq): a Scheme value @end itemize @end deffn @deffn {Procedure} external? obj Return @code{#t} if @var{obj} is an external reference. @end deffn @deffn {Procedure} external-null? extern Return @code{#t} if @var{extern} is null. @end deffn @deffn {Procedure} external-non-null? extern Return @code{#t} if @var{extern} is not null. @end deffn @deffn {Procedure} procedure->external proc Return an external reference that wraps @var{proc} as a function that can be called on the host. This procedure is particularly useful when registering event callbacks on JavaScript hosts. @end deffn @deffn {Syntax} define-external-type name predicate wrap unwrap @deffnx {Syntax} define-external-type name predicate wrap unwrap print Define a new record type named @var{name} for the purposes of wrapping external values. @var{predicate} is the name of the record type predicate. @var{wrap} is the name of the record type constructor. @var{unwrap} is the name of the record field accessor that returns the wrapped value. Optionally, @var{print} is a procedure that accepts two arguments (@code{obj} and @code{port}) and prints a textual representation of the wrapped value. @end deffn @node Evaluation @section Evaluation Hoot is an ahead-of-time, whole-program compiler, but what if we want to evaluate arbitrary Scheme code at runtime? Fortunately, the @code{(hoot eval}) module provides a Scheme interpreter for this purpose! Evaluation happens in the context of an environment. Here's a simple example: @lisp (use-modules (hoot eval) (hoot interaction-environment)) (eval '(let ((x 1) (y 2)) (+ x y)) (interaction-environment)) @end lisp @deffn {Procedure} eval exp toplevel-env Evaluate @code{exp} in the context of the environment @var{toplevel-env}. @end deffn The @code{(hoot interaction-environment)} module provides a way to capture the compile-time environment as an environment that can be used by @code{eval}. @deffn {Procedure} interaction-environment Return an evaluation environment containing all of the bindings in the current module. @end deffn @node Fibers @section Fibers Fibers is a facility for lightweight concurrency in Guile. Hoot's built-in fibers API is based on the third-party @url{https://github.com/wingo/fibers,fibers library} available for the Guile VM. @menu * Fibers example:: A simple example program. * Operations:: Asynchronous events. * Channels:: Communication between fibers. * Timers:: Sleepy fibers. * Conditions:: Send signals between fibers. * Promises:: Integrating fibers with the Wasm host. * Streams:: Stream-based I/O. @end menu @node Fibers example @subsection Fibers example Running a fibers program is a little different than running a regular Scheme program. Fibers programs need to be invoked in an asychronous context from the host (usually JavaScript) and need to communicate the overall success or failure of the program back to the host. To demonstrate, let's make a @emph{very} simple program that sleeps for one second before returning the value @code{42}. @lisp (use-modules (fibers promises) (fibers timers)) (lambda (resolved rejected) (call-with-async-result resolved rejected (lambda () (display "Waiting... ") (force-output) (sleep 1) (display "done!\n") (force-output) 42))) @end lisp Note that we've wrapped our program in a @code{lambda} that receives @code{resolved} and @code{rejected} arguments. When the Wasm host calls this procedure in an asynchronous manner, these arguments will be special host values that are used to resolve or reject the promise (@pxref{Promises}) that represents the result of our program. The @code{call-with-async-result} procedure receives these host values and takes care of all the promise plumbing for us. To try this out, save the above code to @file{fibers-example.scm} and run the following command: @example guild compile-wasm --run --async fibers-test.scm @end example The expected output is: @example Waiting... done! (42) @end example There's just one value returned but since Scheme supports multiple return values, the result of the program is a @emph{list} of values. To invoke an asynchronous procedure from JavaScript, use the @code{call_async} method on a @code{Procedure} object: @example const [proc] = await Scheme.load_main("fibers-test.wasm"); proc.call_async(); @end example Read on for the detailed fibers API reference. @node Operations @subsection Operations Operations are first-class abstractions for asynchronous events. There are primitive operation types, such as waiting for a timer (@pxref{Timers}) or waiting for a message on a channel (@pxref{Channels}). Operations can also be combined and transformed using the @code{choice-operation} and @code{wrap-operation} from the @code{(fibers operations)} module. @deffn {Procedure} wrap-operation op f Given the operation @var{op}, return a new operation that, if and when it succeeds, will apply @var{f} to the values yielded by performing @var{op}, and yield the result as the values of the wrapped operation. @end deffn @deffn {Procedure} choice-operation . ops Given the operations @var{ops}, return a new operation that if it succeeds, will succeed with one and only one of the sub-operations @var{ops}. @end deffn Finally, once you have an operation, you can perform it using @code{perform-operation}. @deffn {Procedure} perform-operation op Perform the operation @var{op} and return the resulting values. If the operation cannot complete directly, block until it can complete. @end deffn There is also a low-level constructor for other modules that implement primitive operation types: @deffn {Procedure} make-base-operation wrap-fn try-fn block-fn Make a fresh base operation. @end deffn @node Channels @subsection Channels Channels are the way to communicate between fibers. To use them, load the @code{(fibers channels)} module. @deffn {Procedure} make-channel Make a fresh channel. @end deffn @deffn {Procedure} channel? obj Return @code{#t} if @var{obj} is a channel, or @code{#f} otherwise. @end deffn @deffn {Procedure} put-operation channel message Make an operation that if and when it completes will rendezvous with a receiving operation to send @var{message} over @var{channel}. @end deffn @deffn {Procedure} get-operation channel Make an operation that if and when it completes will rendezvous with a sending operation to receive one value from @var{channel}. @end deffn @deffn {Procedure} put-message channel message Send @var{message} on @var{channel}, and return zero values. If there is already a receiver waiting to receive a message on this channel, give it our message and continue. Otherwise, block until a receiver becomes available. Equivalent to: @lisp (perform-operation (put-operation channel message)) @end lisp @end deffn @deffn {Procedure} get-message channel Receive a message from @var{channel} and return it. If there is already a sender waiting to send a message on this channel, take its message directly. Otherwise, block until a sender becomes available. Equivalent to: @lisp (perform-operation (get-operation channel)) @end lisp @end deffn @node Timers @subsection Timers Timers are a kind of operation that, you guessed it, let you sleep until a certain time. The timer API can be found in the @code{(fibers timers)} module. @deffn {Procedure} sleep-operation seconds Make an operation that will succeed with no values when @var{seconds} have elapsed. @end deffn @deffn {Procedure} timer-operation expiry Make an operation that will succeed when the current time is greater than or equal to @var{expiry}, expressed in internal time units. The operation will succeed with no values. @end deffn @deffn {Procedure} sleep seconds Block the calling fiber until @var{seconds} have elapsed. @end deffn @node Conditions @subsection Conditions Condition variables are a simple one-bit form of concurrent communication. A condition variable has two states: it starts in the @dfn{unsignalled} state and later may transition to the @dfn{signalled} state. When a condition becomes signalled, any associated waiting operations complete. The following API can be found in the @code{(fibers conditions)} module. @deffn {Procedure} make-condition Make a new condition variable. @end deffn @deffn {Procedure} condition? obj Return @code{#t} if @var{obj} is a condition variable, or @code{#f} otherwise. @end deffn @deffn {Procedure} signal-condition! cvar Signal @var{cvar}, notifying all waiting fibers and preventing blocking of future fibers waiting on this condition. @end deffn @deffn {Procedure} wait-operation cvar Make an operation that will succeed with no values when @var{cvar} becomes signalled. @end deffn @deffn {Procedure} wait cvar Block the calling fiber until @var{cvar} becomes signalled. Equivalent to @code{(perform-operation (wait-operation cvar))}. @end deffn @node Promises @subsection Promises Promises represent the result of a computation that may or may not complete at some later point in time. They are the primitive upon which asynchronous concurrency is based in @url{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Promise,JavaScript}, whether using promises directly or through the @url{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Statements/async_function,async}/@url{https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/await,await} syntax. Hoot fibers use these host promises under the hood and the @code{(fibers promises)} module provides the API for doing so. This is @emph{mostly} transparent to the programmer, except at program startup. Programs that use fibers must be called in an async context in which they receive special values used to resolve or reject the promise representing the result of the entire program. @xref{Fibers example} for a walkthrough of this process. @deffn {Procedure} await-promise-operation promise Make an operation that will complete when @var{promise} is resolved. Performing the operation produces one value: a thunk which when called will either return the value or throw an exception. @end deffn @deffn {Procedure} await promise Suspend the current fiber until @var{promise} is resolved. If the promise resolves successfully, one value is returned. Otherwise, an exception is thrown. @end deffn @deffn {Procedure} call-with-async-result resolved rejected thunk Call @var{thunk} and resolve the promise with @var{resolved} and the returned values. If an exception is thrown, the promise is rejected with @var{rejected} and the exception. @var{resolved} and @var{rejected} are external host values that are obtained by calling a Scheme procedure asynchronously from the host. See the @code{Procedure.call_async} method in @ref{JavaScript reflection} and the @code{hoot-apply-async} procedure in @ref{Reflection} for more information on asynchronous procedure calls. @end deffn @node Streams @subsection Streams The @code{(fibers streams)} module provides an interface for wrapping @url{https://developer.mozilla.org/en-US/docs/Web/API/Streams_API,web stream} objects from the host with Scheme ports. @deffn {Procedure} open-input-stream stream Return an input port that reads from @var{stream}, an external reference to a stream. @end deffn @deffn {Procedure} open-output-stream stream Return an output port that writes to @var{stream}, an external reference to a stream. @end deffn @defvr {Variable} standard-input-stream An input port that reads from the host's standard input stream. @end defvr @defvr {Variable} standard-output-stream An output port that writes to the host's standard output stream. @end defvr @defvr {Variable} standard-error-stream An output port that writes to the host's standard error stream. @end defvr @node Finalization @section Finalization The @code{(hoot finalization)} module provides an interface for the JavaScript @url{https://developer.mozilla.org/docs/Web/JavaScript/Reference/Global_Objects/FinalizationRegistry,FinalizationRegistry} class, which notifies user code when a registered object has been garbage collected. Finalization registries are quite different from Guile's @inlinefmtifelse{html, @url{https://www.gnu.org/software/guile/manual/html_node/Guardians.html, guardians}, @ref{Guardians,,,Guile Reference}}: @itemize @item Guardians return references to the objects they have protected from garbage collection. Finalization registries @emph{do not} protect objects from garbage collection at all. Instead, when a registered object is garbage collected, the finalization registry passes along a user-specified ``held value''. A held value @emph{cannot} be a reference to the object being registered for finalization. @item Guardians are polled, whereas finalization registries use an asynchronous callback function. @item Finalization registries allow objects to be unregistered, whereas objects cannot be removed from a guardian once they have been added. @end itemize The following contrived example will print ``hey'' when the registered object is garbage collected: @lisp (define (cleanup x) (display x) (newline)) (define registry (make-finalization-registry cleanup)) (finalization-registry-register! registry (list 'garbage) 'hey) @end lisp @deffn {Procedure} make-finalization-registry cleanup Return a new finalization registry that will call @var{cleanup} (a procedure of one argument) whenever a registered object is garbage collected. @end deffn @deffn {Procedure} finalization-registry? obj Return @var{#t} if @var{obj} is a finalization registry. @end deffn @deffn {Procedure} finalization-registry-register! registry target held-value [unregister-token] Register @var{target} with @var{registry}. When @var{target} is garbage collected, the cleanup callback will receive @var{held-value}. @var{held-value} @emph{cannot} be @code{eq?} to @var{target}. If @var{unregister-token} is specified and not @code{#f} then this token can be used to unregister @var{target} later. @end deffn @deffn {Procedure} finalization-registry-unregister! registry unregister-token Unregister the objects associated with @var{unregister-token} from @var{registry}. Return @var{#t} if at least one object was unregistered this way. @end deffn @node Toolchain reference @chapter Toolchain reference Hoot is not just a Scheme to Wasm compiler. It's also a self-contained and general purpose Wasm toolchain. Hoot does not use binaryen, wabt, emscripten, etc. in order to assemble and disassemble Wasm. The entire toolchain is implemented as a set of Scheme modules that can be used to automate other Wasm targeted build workflows. Since everything is implemented in one place, in a single language, and because Guile encourages a REPL-driven development workflow, Hoot makes a great platform for learning Wasm in a hands-on, interactive way! @menu * Data types:: Core Wasm module data types. * Text format:: Guile-flavored WebAssembly Text format. * Resolver:: Lower symbolic identifiers to integer identifiers. * Symbolifier:: Lift integer identifiers to symbolic identifiers. * Linker:: Add a standard library to a Wasm module. * Assembler:: Create Wasm binaries. * Binary Parser:: Parse Wasm binaries. * Printer:: Print the contents of a Wasm module. * Interpreter:: Execute Wasm within Guile. * Wasm REPL commands:: Run and debug Wasm at the REPL. @end menu @node Data types @section Data types The @code{(wasm types)} module contains all the core data types that comprise a Wasm module. @subsection Modules The Wasm module type is the top type, incorporating values of all the types that are to follow. @deffn {Procedure} wasm? obj Return @code{#t} if @var{obj} is a Wasm module. @end deffn @deffn {Procedure} wasm-id wasm Return the symbolic ID of @var{wasm}. @end deffn @deffn {Procedure} wasm-types wasm Return the list of types in @var{wasm}. @end deffn @deffn {Procedure} wasm-imports wasm Return the list of imports in @var{wasm}. @end deffn @deffn {Procedure} wasm-funcs wasm Return the list of functions in @var{wasm}. @end deffn @deffn {Procedure} wasm-tables wasm Return the list of tables in @var{wasm}. @end deffn @deffn {Procedure} wasm-memories wasm Return the list of memories in @var{wasm}. @end deffn @deffn {Procedure} wasm-globals wasm Return the list of globals in @var{wasm}. @end deffn @deffn {Procedure} wasm-exports wasm Return the list of exports in @var{wasm}. @end deffn @deffn {Procedure} wasm-elems wasm Return the list of element segments in @var{wasm}. @end deffn @deffn {Procedure} wasm-datas wasm Return the list of data segments in @var{wasm}. @end deffn @deffn {Procedure} wasm-tags wasm Return the list of tags in @var{wasm}. @end deffn @deffn {Procedure} wasm-strings wasm Return the list of strings in @var{wasm}. @end deffn @deffn {Procedure} wasm-custom wasm Return the list of custom segments in @var{wasm}. @end deffn @deffn {Procedure} wasm-start wasm Return the start function index for @var{wasm}. @end deffn @subsection Types Wasm has four numeric types: @enumerate @item @code{i32}: 32-bit integer (signed or unsigned) @item @code{i64}: 64-bit integer (signed or unsigned) @item @code{f32}: 32-bit single precision IEEE floating point number. @item @code{f64}: 64-bit double precision IEEE floating point number. @end enumerate There is also the @code{v128} vector type, but it is currently unsupported. Then there are a number of reference types that fall into 3 categories: function, external, and internal. Function reference types: @enumerate @item @code{func}: Function reference. @item @code{nofunc}: Bottom type for functions. No function is of type @code{nofunc}. @end enumerate External reference types: @enumerate @item @code{extern}: External reference introduced by the host. @item @code{noextern}: Bottom type for external references. No external reference is of type @code{noextern}. @end enumerate Internal reference types: @enumerate @item @code{any}: The top type of all internal reference types. @item @code{eq}: Structural equivalence type. Subtype of @code{all}. @item @code{i31}: Used for immediate references (such as the empty list or fixnums in Scheme.) Subtype of @code{eq}. @item @code{array}: Super type of all array types. Subtype of @code{eq}. @item @code{struct}: Super type of all struct types. Subtype of @code{eq}. @item @code{none}: The bottom type for internal references. No internal reference is of type @code{none}. @end enumerate Of course, modules may specify their own compound types assembled from these primitives. The type hierarchy looks like this: @verbatim .-----. .-------. .---------. | any | | func | | extern | `-----' `-------' `---------' ā†“ ā†“ ā†“ .-----. .-----------. .-----------. .-------- | eq | ------------. | all funcs | | noextern | | `-----' | `-----------' `-----------' ā†“ ā†“ ā†“ ā†“ .-----. .-------------. .---------. .---------. | i31 | | all arrays | | struct | | nofunc | `-----' `-------------' `---------' `---------' ā†“ ā†“ .-----. .-------------. | any | | all structs | `-----' `-------------' @end verbatim A collection of type descriptor objects form a type table that describes all non-primitive types used within a module. Type objects associate an identifier with a function signature or reference type descriptor. @deffn {Procedure} type? obj Return @code{#t} if @var{obj} is a type. @end deffn @deffn {Procedure} type-id type Return the symbolic ID of @var{type}. @end deffn @deffn {Procedure} type-val type Return the type descriptor of @var{type}. @end deffn Types may also be nested within recursive type groups that allow for circular and self references to the types within the group. Types @emph{not} within a group can be thought of as belonging to a group of one. @deffn {Procedure} rec-group? obj Return @code{#t} if @var{obj} is a recursive type group. @end deffn @deffn {Procedure} rec-group-types rec-group Return the types within @var{rec-group}. @end deffn Note that while each Wasm module contains a full inventory of its types, structurally identical type groups across Wasm modules are canonicalized at runtime and are considered to be identical (@code{eq?} in Scheme terms.) This allows for passing references between modules. Type uses refer to function signatures and are used for specifying the type of a @code{block}, @code{loop}, or @code{if} expression. @deffn {Procedure} type-use? obj Return @code{#t} if @var{obj} is a type use. @end deffn @deffn {Procedure} type-use-idx type-use Return the type index of @var{type-use}. @end deffn @deffn {Procedure} type-use-sig type-use Return the function signature of @var{type-use}. @end deffn @deffn {Procedure} ref-type? obj Return @code{#t} if @var{obj} is a reference type. @end deffn @deffn {Procedure} ref-type-nullable? ref-type Return @var{#t} if @var{ref-type} is nullable. @end deffn @deffn {Procedure} ref-type-heap-type ref-type Return the heap type of @var{ref-type}. @end deffn As mentioned above, reference types support structural subtyping. @deffn {Procedure} sub-type? obj Return @code{#t} if @var{obj} is a sub type. @end deffn @deffn {Procedure} sub-type-final? sub-type Return @code{#t} if @var{sub-type} is marked as final. @end deffn @deffn {Procedure} sub-type-supers sub-type Return super types of @var{sub-type}. @end deffn @deffn {Procedure} sub-type-type sub-type Return the concrete type descriptor of @var{sub-type}. @end deffn Compound types take the form of arrays and structs. @deffn {Procedure} array-type? obj Return @code{#t} if @var{obj} is an array type. @end deffn @deffn {Procedure} array-type-mutable? array-type Return @code{#t} if @var{array-type} is mutable. @end deffn @deffn {Procedure} array-type-type array-type Retun the element type descriptor of @var{array-type}. @end deffn @deffn {Procedure} struct-type? obj Return @code{#t} if @var{obj} is a struct type. @end deffn @deffn {Procedure} struct-type-fields struct-type Return the field descriptors of @var{struct-type}. @end deffn Struct types are composed of several fields. @deffn {Procedure} field? obj Return @code{#t} if @var{obj} is a struct field. @end deffn @deffn {Procedure} field-id field Return the symbolic ID of @var{field}. @end deffn @deffn {Procedure} field-mutable? field Return @code{#t} if @var{field} is mutable. @end deffn @deffn {Procedure} field-type field Return the type descriptor of @var{field}. @end deffn Both arrays and struct fields allow for packed data using the special @code{i8} and @code{i16} data types. @subsection Globals Wasm supports both mutable and immutable global variables. @deffn {Procedure} global? obj Return @code{#t} if @var{obj} is a global. @end deffn @deffn {Procedure} global-id global Return the symbloc ID of @var{global}. @end deffn @deffn {Procedure} global-type global Return the type of @var{global}. @end deffn @deffn {Procedure} global-init global Return the initialization instructions of @var{global}. Only constant instructions are allowed. @end deffn @deffn {Procedure} global-type? obj Return @code{#t} if @var{obj} is a global type. @end deffn @deffn {Procedure} global-type-mutable? global-type Return @code{#t} if @var{global-type} is mutable. @end deffn @deffn {Procedure} global-type-type global-type Return the type descriptor of @var{global-type}. @end deffn @subsection Functions @deffn {Procedure} func? obj Return @code{#t} if @var{obj} is a function. @end deffn @deffn {Procedure} func-id func Return the symbolic ID of @var{func}. @end deffn @deffn {Procedure} func-type func Return the signature of @var{func}. @end deffn @deffn {Procedure} func-locals func Return the locals of @var{func}. @end deffn @deffn {Procedure} func-body func Return the body instructions of @var{func}. @end deffn The type of a function is its signature. Notably, Wasm supports multiple return values, just like Scheme. @deffn {Procedure} func-sig? obj Return @code{#t} if @var{obj} is a function signature. @end deffn @deffn {Procedure} func-sig-params func Return the parameters of @var{func}. @end deffn @deffn {Procedure} func-sig-results func Return the result types of @var{func}. @end deffn Function parameters pair a local identifier with its type. @deffn {Procedure} param? obj Return @code{#t} if @var{obj} is a param. @end deffn @deffn {Procedure} param-id param Return the symbolic ID of @var{param}. @end deffn @deffn {Procedure} param-type param Return the type descriptor of @var{param}. @end deffn Locals provide additional mutable variables scoped to the body of a function. @deffn {Procedure} local? obj Return @code{#t} if @var{obj} is a function local. @end deffn @deffn {Procedure} local-id local Return the symbolic ID of @var{local}. @end deffn @deffn {Procedure} local-type local Return the type descriptor of @var{local}. @end deffn @subsection Imports/exports Functions, globals, memories, and tables can be imported from the host or another Wasm module. They are organized into a two layer hierarchy. An import module groups many imports under an umbrella name, and then the individual item names distinguish imported data within a module. @deffn {Procedure} import? obj Return @code{#t} if @var{obj} is an import. @end deffn @deffn {Procedure} import-mod import Return the module name string of @var{import}. @end deffn @deffn {Procedure} import-name import Return the name string of @var{import}. @end deffn @deffn {Procedure} import-kind import Return the kind of @var{import}. Either @code{func}, @code{global}, @code{memory}, or @code{table}. @end deffn @deffn {Procedure} import-id import Return the symbolic ID of @var{import}. @end deffn @deffn {Procedure} import-type import Return the type descriptor of @var{import}. @end deffn Likewise, functions, globals, memories, and tables can be exported from a module to be used by the host or by other modules. @deffn {Procedure} export? obj Return @code{#t} if @var{obj} is an export. @end deffn @deffn {Procedure} export-name export Return the name string of @var{export}. @end deffn @deffn {Procedure} export-kind export Return the kind of @var{export}. Either @code{func}, @code{global}, @code{memory}, or @code{table}. @end deffn @deffn {Procedure} export-idx export Return the index of @var{export}. @end deffn @subsection Linear memory Memory objects specify linear chunks of bytes that a module can write to/read from at runtime. The size of a memory is specified in terms of 64KiB pages. While many memory objects coud be included in a module, the Wasm specification currently only allows the use of a single memory at index 0. @deffn {Procedure} memory? obj Return @code{#t} if @var{obj} is a memory. @end deffn @deffn {Procedure} memory-id memory Return the symbolic ID of @var{memory}. @end deffn The type of a memory currently just specifies the size limitations. @deffn {Procedure} memory-type memory Return the type of @var{memory}. @end deffn @deffn {Procedure} mem-type? obj Return @code{#t} if @var{obj} is a memory type. @end deffn @deffn {Procedure} mem-type-limits mem-type Return the limits of @var{mem-type}. @end deffn Instructions that manipulate linear memory use the memory argument type to point to a specific offset within a memory. @deffn {Procedure} mem-arg? obj Return @code{#t} if @var{obj} is a memory argument. @end deffn @deffn {Procedure} mem-arg-id mem-arg Return the symbolic ID of @var{mem-arg}. @end deffn @deffn {Procedure} mem-arg-offset mem-arg Return the offset of @var{mem-arg}. @end deffn @deffn {Procedure} mem-arg-align mem-arg Return the alignment of @var{mem-arg}. @end deffn @subsection Data segments Data segments are static chunks of data used to initialize regions of memory. They have two possible modes of use: @enumerate @item @strong{Active:} The data segment is copied into memory during instantiation. @item @strong{Passive:} The data segment is copied into memory using the @code{memory.init} instruction. @end enumerate @deffn {Procedure} data? obj Return @code{#t} if @var{obj} is a data segment. @end deffn @deffn {Procedure} data-id data Return the symbolic ID of @var{data}. @end deffn @deffn {Procedure} data-mode data Return the mode of @var{data}. Either @code{passive} or @code{active}. @end deffn @deffn {Procedure} data-mem data Return the memory associated with @var{data}. @end deffn @deffn {Procedure} data-offset data Return the instructions that compute the offset of @var{data}. Only constant instructions are allowed. @end deffn @deffn {Procedure} data-init data Return a bytevector containing the initialization data of @var{data}. @end deffn @subsection Tables Tables specify a vector of heap object references of a particular reference type. @deffn {Procedure} table? obj Return @code{#t} if @var{obj} is a reference table. @end deffn @deffn {Procedure} table-id table Return the symbolic ID of @var{table}. @end deffn @deffn {Procedure} table-type table Return the type of @var{table}. @end deffn Table types specify the reference type of the elements as well as the size limitations. @deffn {Procedure} table-type? obj Return @code{#t} if @var{obj} is a table type. @end deffn @deffn {Procedure} table-type-limits table-type Return the limts of @var{table-type}. @end deffn @deffn {Procedure} table-type-elem-type table-type Return the element type of @var{table-type}. @end deffn @subsection Element segments Element segments are static vectors of references used to initialize regions of tables (well, mostly.) They have three possible modes of use: @enumerate @item @strong{Active:} The element segment is copied into its associated table during instantiation. @item @strong{Passive:} The element segment is copied into its associated table using the @code{table.init} instruction. @item @strong{Declarative:} The element segment is unavailable at runtime and is instead used for forward declarations of types that are used elsewhere in the code. @end enumerate @deffn {Procedure} elem? obj Return @code{#t} if @var{obj} is an element segment. @end deffn @deffn {Procedure} elem-id elem Return the symoblic ID of @var{elem}. @end deffn @deffn {Procedure} elem-mode elem Return the mode of @var{elem}. @end deffn @deffn {Procedure} elem-table elem Return the table associated with @var{elem}. @end deffn @deffn {Procedure} elem-type elem Return the type of @var{elem}. @end deffn @deffn {Procedure} elem-offset elem Return the instructions that compute the offset of @var{elem}. Only constant instructions are allowed. @end deffn @deffn {Procedure} elem-inits elem Return a list of initializer instructions for the items of @var{elem}. Only constant instructions are allowed. @end deffn @subsection Limits Both memories and tables use limits to constrain their minimum and maximum size. A valid limit must have a minimum of at least 1, but the maximum may be @code{#f} if unbounded growth is allowed. @deffn {Procedure} limits? obj Return @code{#t} if @var{obj} is a limits. @end deffn @deffn {Procedure} limits-min limits Return the minimum value of @var{limits}. @end deffn @deffn {Procedure} limits-max limits Return the maximum value of @var{limits} or @code{#f} if there is no maximum. @end deffn @subsection Tags Tag segments specify types of runtime errors that may be raised. @deffn {Procedure} tag? obj Return @code{#t} if @var{obj} is a tag. @end deffn @deffn {Procedure} tag-id tag Return the symbolic ID of @var{tag}. @end deffn @deffn {Procedure} tag-type tag Return the type of @var{tag}. @end deffn Tag types specify the function signature of the tags. Since tags are not truly functions, their signatures must only have parameters and no results. @deffn {Procedure} tag-type? obj Return @code{#t} if @var{obj} is a tag type. @end deffn @deffn {Procedure} tag-type-attribute tag-type Return the symbolic attribute of @var{tag-type}. Currently, there is only one valid attribute: @code{exception}. @end deffn @deffn {Procedure} tag-type-type tag-type Return the type of @var{tag-type}. This is expected to be a type use object that refers to a function signature. @end deffn @subsection Custom sections Custom sections specify arbitrary data that is not covered by the Wasm specification. @deffn {Procedure} custom? obj Return @code{#t} if @var{obj} is a custom segment. @end deffn @deffn {Procedure} custom-name custom Return the name of @var{custom}. @end deffn @deffn {Procedure} custom-bytes custom Return the bytevector of @var{custom}. @end deffn There is, however, one custom section that @emph{is} specified: the name section. This section contains various ``name maps'' that can be used to translate integer identifiers to (hopefully) human-readable names for the purposes of debugging. Hoot supports the name subsections described in the Wasm core specification, the Wasm GC specification, and the extended names proposal: @enumerate @item Module name @item Function name map @item Function local indirect name map @item Block label indirect name map @item Type name map @item Table name map @item Memory name map @item Global name map @item Element name map @item Data name map @item Struct field indirect name map @item Tag name map @end enumerate Name maps are represented as association lists mapping integers to strings. Indirect name maps are represented as association lists mapping integers to name maps. @deffn {Procedure} names? obj Return @code{#t} if @var{obj} is a name section object. @end deffn @deffn {Procedure} names-module names Return the module name of @var{names}. @end deffn @deffn {Procedure} names-func names Return the function name map of @var{names}. @end deffn @deffn {Procedure} names-local names Return the function local indirect name map of @var{names}. @end deffn @deffn {Procedure} names-label names Return the block label indirect name map of @var{names}. @end deffn @deffn {Procedure} names-type names Return the type name map of @var{names}. @end deffn @deffn {Procedure} names-table names Return the table name map of @var{names}. @end deffn @deffn {Procedure} names-memory names Return the memory name map of @var{names}. @end deffn @deffn {Procedure} names-global names Return the global name map of @var{names}. @end deffn @deffn {Procedure} names-elem names Return the element name map of @var{names}. @end deffn @deffn {Procedure} names-data names Return the data name map of @var{names}. @end deffn @deffn {Procedure} names-fields names Return the struct field indirect name map of @var{names}. @end deffn @deffn {Procedure} names-tag names Return the tag name map of @var{names}. @end deffn @node Text format @section Text format The @code{(wasm wat)} module provides a parser for a variant of WebAssembly Text (WAT) format. Since WAT uses an s-expression syntax that resembles but is distinct from Scheme syntax, Hoot opts to represent WAT code as Scheme expressions. This allows for embedding WAT directly into Scheme code and programmatically generating WAT code via quasiquote templating or other means. We call this variant GWAT where the ``G'' stands for ``Guile'', of course. Hoot's WAT variant has some additional expressive power such as allowing string constants, bytevectors for data segments, and i32/i64 constants in either the signed or unsigned range. WAT has two variants: unfolded and folded. In the unfolded form, instruction sequences are linear, as they would be in the resulting binary: @lisp '(module (func (export "add") (param $a i32) (param $b i32) (result i32) (local.get $a) (local.get $b) (i32.add))) @end lisp The folded form allows instructions to be nested within each other: @lisp '(module (func (export "add") (param $a i32) (param $b i32) (result i32) (i32.add (local.get $a) (local.get $b)))) @end lisp This form looks more like Scheme procedure calls and is generally easier to write and reason about. @deffn {Procedure} wat->wasm expr Parse @var{expr}, a Wasm module expressed as WAT code, and return a Wasm module. @lisp (wat->wasm '(module (func (export "add") (param $a i32) (param $b i32) (result i32) (i32.add (local.get $a) (local.get $b))))) @end lisp The returned Wasm module preserves named references, among other things, and is thus unsuitable as input to the assembler or interpreter. To lower the module into a usable form, see @code{resolve-wasm} in @ref{Resolver}. @end deffn @deffn {Procedure} wasm->wat wasm Disassemble @var{wasm} and return its symbolic WAT form. @var{wasm} is assumed to be in @emph{symbolified} form (@pxref{Symbolifier}). @end deffn @node Resolver @section Resolver The @code{(wasm resolve)} module provides the @code{resolve-wasm} procedure which lowers Wasm modules into a form that can be used by the assembler or interpreter. The resolver replaces named references with their respective integer identifiers, fills out the type table, and adjusts i32 and i64 constants into their canonical form. @deffn {Procedure} resolve-wasm mod [#:emit-names? #f] Lower the Wasm module @var{mod} into a form that can be assembled or interpreted. Returns a new Wasm module and does not modify @var{mod}. When @var{emit-names?} is @code{#t}, the returned Wasm module will include a name map that maps the original, human-readable names to the resolved integer identifiers. @end deffn @node Symbolifier @section Symbolifier The @code{(wasm symbolify)} module does the opposite of @code{(wasm resolve)} by giving symbolic names to all objects in a Wasm module. Symbolified Wasm is useful for disassembling binaries (see @code{wasm->wat} in @ref{Text format}). @deffn {Procedure} symbolify-wasm wasm Return a new Wasm module derived from @var{wasm} where all definitions and uses have been given unique symbolic identifiers. @end deffn @node Linker @section Linker The @code{(wasm link)} module provides a means for extending a Wasm module with the standard library that it needs at runtime. Hoot uses the linker to add the Scheme runtime to the compiled form of user code. The linker uses a form of tree-shaking to remove anything that is not used by the base module. @deffn {Procedure} add-stdlib wasm stdlib Return a new Wasm module that is the combination of the Wasm module @var{wasm} with the Wasm module @var{stdlib}. @end deffn @node Assembler @section Assembler The @code{(wasm assemble)} module is used to lower Wasm modules into the Wasm binary format. @deffn {Procedure} assemble-wasm wasm Return a bytevector containing the assembled binary form of the Wasm module @var{wasm}. @end deffn @node Binary Parser @section Binary Parser The @code{(wasm parse)} module parses the Wasm binary format. @deffn {Procedure} parse-wasm port Parse the Wasm binary data from @var{port} and return a Wasm module. @end deffn @node Printer @section Printer The @code{(wasm dump)} module provides the @code{dump-wasm} procedure for generating a detailed print-out of a Wasm module's contents. See also @ref{Wasm REPL commands} for the @code{wasm-dump} REPL command. @deffn {Procedure} dump-wasm mod [#:port] [#:dump-func-defs? #t] Write a detailed inventory of the Wasm module @var{mod} to @var{port} or the current output port if @var{port} is not specified. If @var{dump-func-defs?} is @code{#t}, which is the default, all function definitions are printed, including the instructions in the body of each. Depending on the size of the module, this may be an overwhelming amount of data, thus it is made optional. @end deffn @node Interpreter @section Interpreter The @code{(wasm vm)} module provides a virtual machine for interpreting Wasm functions. To use the interpreter, a Wasm module is first validated for type safety (among other things) and then instantiated, at which point exported functions become callable from Scheme. The interpreter only accepts validated Wasm. The @code{validate-wasm} procedure validates and wraps a Wasm module to indicate successful validation: @lisp (use-modules (wasm vm) (wasm resolve)) (define validated-wasm (validate-wasm (wat->wasm '(module (func (export "main") (result i32) (i32.const 42)))))) @end lisp When starting with a Wasm binary, the convenient @code{load-and-validate-wasm} procedure parses the binary and then performs validation: @lisp (call-with-input-file "hello.wasm" load-and-validate-wasm) @end lisp Once the Wasm module has been validated, the runtime data needed for interpretation can be created by instantiating the module: @lisp (define instance (instantiate-wasm validated-wasm)) @end lisp Exported Wasm functions then become usable as Scheme procedures: @lisp (define wasm-main (wasm-instance-export-ref instance "main")) (wasm-main) ;; => 42 @end lisp Wasm functions are statically typed, which means that calls from Scheme to Wasm require runtime type checking for each call. @subsection Validation @deffn {Procedure} validate-wasm wasm Validate the Wasm module @var{wasm} and return a validated Wasm object. @end deffn @deffn {Procedure} load-and-validate-wasm obj Load and validate the Wasm module within @var{obj} then return a validated Wasm object. @var{obj} may be a @code{} record as produced by @code{resolve-wasm} (@pxref{Resolver}), a bytevector containing a Wasm binary, or an input port from which to read a Wasm binary. @end deffn @deffn {Procedure} validated-wasm? obj Return @code{#t} if @var{obj} is a validated Wasm object. @end deffn @deffn {Procedure} validated-wasm-ref validated-wasm Unbox and return the Wasm module within @var{validated-wasm}. @end deffn @subsection Instantiation @deffn {Procedure} instantiate-wasm wasm [#:imports '()] Return a new Wasm instance for the validated Wasm module @var{wasm}. @var{imports} is a nested association list of imported functions, globals, memories, and tables. Wasm imports are identified by a module name and an object name. Consider the following Wasm module that computes 2D polar coordinates and prints them to a log: @lisp (use-modules (wasm resolve) (wasm vm) (wasm wat)) (define the-module (resolve-wasm (wat->wasm '(module (func $logf64 (import "debug" "logf64") (param f64)) (func $cos (import "math" "cos") (param f64) (result f64)) (func $sin (import "math" "sin") (param f64) (result f64)) (func (export "polar") (param $r f64) (param $theta f64) (call $logf64 (f64.mul (local.get $r) (call $cos (local.get $theta)))) (call $logf64 (f64.mul (local.get $r) (call $sin (local.get $theta))))))))) @end lisp This module requires three imported functions from two modules. Thus the module instantiation code would look like this: @lisp (define (logf64 x) (format #t "f64: ~a\n" x)) (define the-instance (instantiate-wasm (validate-wasm the-module) #:imports `(("debug" . (("logf64" . ,logf64))) ("math" . (("cos" . ,cos) ("sin" . ,sin)))))) @end lisp @end deffn @subsection Globals @deffn {Procedure} make-wasm-global value mutable? Return a new Wasm global containing @var{value}. When @var{mutable?} is @code{#f}, the value cannot be modified later. @end deffn @deffn {Procedure} wasm-global? obj Return @code{#t} if @var{obj} is a Wasm global. @end deffn @deffn {Procedure} wasm-global-ref global Return the current value within @var{global}. @end deffn @deffn {Procedure} wasm-global-set! global val Set the value within @var{global} to @var{val}. An exception is raised if @var{global} is immutable. @end deffn @deffn {Procedure} wasm-global-mutable? global Return @code{#t} if @var{global} is mutable. @end deffn @subsection Memories @deffn {Procedure} make-wasm-memory size [#:limits (make-limits 1 #f)] Return a new Wasm linear memory containing @var{size} 64KiB pages. @var{limits} determines the lower and upper bounds of how many pages this memory can store. The default limits are a minimum of 1 page and no maximum page limit. @xref{Data types} for more information on limit objects. @end deffn @deffn {Procedure} wasm-memory? obj Return @code{#t} if @var{obj} is a Wasm memory. @end deffn @deffn {Procedure} wasm-memory-bytes memory Return the current bytevector representing the pages of @var{memory}. @end deffn @deffn {Procedure} wasm-memory-size memory Return the size of @var{memory} in 64KiB pages. @end deffn @deffn {Procedure} wasm-memory-limits memory Return the limits of @var{memory} @end deffn @deffn {Procedure} wasm-memory-grow! memory n Increase the size of @var{memory} by @var{n} pages. An exception is raised if growing by @var{n} exceeds the limits of @var{memory}. @end deffn @subsection Tables @deffn {Procedure} make-wasm-table size [#:limits (make-limits 1 #f)] Return a new Wasm reference table containing @var{size} element slots. @var{limits} determines the lower and upper bounds of how many elements this table can store. The default limits are a minimum of 1 element and no maximum element limit. @xref{Data types} for more information on limit objects. @end deffn @deffn {Procedure} wasm-table? Return @code{#t} if @var{obj} is a Wasm table. @end deffn @deffn {Procedure} wasm-table-size table Return the size of @var{table}. @end deffn @deffn {Procedure} wasm-table-ref table i Return the reference at the @var{i}th index in @var{table}. @end deffn @deffn {Procedure} wasm-table-set! table i x Set the @var{i}th element of @var{table} to @var{x}, a Wasm reference type. @end deffn @deffn {Procedure} wasm-table-fill! table start fill length Fill the elements of @var{table} from @var{start} to @var{start} + @var{length}, exclusive, with the value @var{fill}. @end deffn @deffn {Procedure} wasm-table-copy! table at elems start length Copy the block of elements from vector @var{elems}, from @var{start} to @var{start} + @var{length}, exclusive, to @var{table}, starting at @var{at}. @end deffn @deffn {Procedure} wasm-table-grow! table n init Increase the size of @var{table} by @var{n} elements. An exception is raised if growing by @var{n} exceeds the limits of @var{table}. @end deffn @subsection Observation Every Wasm instruction evaluated by interpreter can be observed via the @code{current-instruction-listener} parameter. Use this hook to instrument Wasm modules. The following instruction listener would print every instruction's name on a separate line: @lisp (define (log-instr instr path instance stack blocks locals) (display (car instr)) (newline)) (parameterize ((current-instruction-listener log-instr)) ...) @end lisp @defvar current-instruction-listener The current instruction observation hook which is invoked @emph{before} each instruction evaluation. Must be a procedure that accepts the following arguments: @enumerate @item @strong{Instruction:} The symbolic Wasm instruction to be evaluated. @item @strong{Path:} The symbolic location of the instruction within the Wasm module. @item @strong{Instance:} The instance that is evaluating the instruction. @item @strong{Stack:} The Wasm value stack. @item @strong{Blocks:} The Wasm block stack, which is just a list of prompt tags. @item @strong{Locals:} The Wasm function locals. @end enumerate @end defvar The Wasm value stack is a special data type with the following API: @deffn {Procedure} wasm-stack? obj Return @code{#t} if @var{obj} is a Wasm value stack. @end deffn @deffn {Procedure} wasm-stack-items stack Return the values on @var{stack} as a list. @end deffn @node Wasm REPL commands @section Wasm REPL commands The @code{(hoot repl)} module provides a set of REPL commands to assist with inspecting and debugging Wasm modules. As a matter of course, Hoot's Scheme compiler @emph{should not} cause low-level Wasm runtime errors, but when it does, or when working with the Wasm toolchain directly, these REPL tools may provide some assistance. To install the REPL commands, simply import the module: @lisp scheme@@(guile-user)> ,use (hoot repl) @end lisp To see a list of all the Wasm commands, run: @lisp scheme@@(guile-user)> ,help wasm @end lisp To demonstrate the debugging features, let's create a trivial module with a buggy function: @lisp @verbatim scheme@(guile-user)> (define src '(module (func (export "main") (param $x i32) (result i32) (i32.add (local.get $x) (unreachable))))) @end verbatim @end lisp When called, this function will hit the @code{unreachable} instruction and throw a runtime error. Let's compile the WAT source, load it into the VM, and get a reference to the @code{main} function: @lisp @verbatim scheme@(guile-user)> ,use (wasm resolve) (wasm vm) (wasm wat) scheme@(guile-user)> (define wasm (validate-wasm (resolve-wasm (wat->wasm src)))) scheme@(guile-user)> (define instance (instantiate-wasm wasm)) scheme@(guile-user)> (define main (wasm-instance-export-ref instance "main")) @end verbatim @end lisp To trap the Wasm runtime error and open a Wasm debugging REPL, the @command{wasm-catch} REPL command can be prefixed before an expression: @lisp @verbatim scheme@(guile-user)> ,wasm-catch (main 7) ice-9/boot-9.scm:1674:22: In procedure raise-exception: ERROR: 1. &wasm-runtime-error: instruction: (unreachable) position: (func 0 1) instance: # stack: #< items: (7)> blocks: ((wasm-block)) locals: #(7) 2. &message: "Wasm runtime error: unreachable" 3. &irritants: () Entering Wasm debug prompt. Type `,help wasm' for info or `,q' to continue. scheme@(guile-user) [1]> @end verbatim @end lisp Once in a Wasm debug context, many of the other REPL commands become usable. To highlight the instruction where execution has paused, use @command{wasm-pos}: @lisp @verbatim scheme@(guile-user) [1]> ,wasm-pos (func 0 (param $x i32) (result i32) (local.get 0) <<< (unreachable) >>> (i32.add)) @end verbatim @end lisp To print the contents of the values stack, use @command{wasm-stack}: @lisp @verbatim scheme@(guile-user) [1]> ,wasm-stack Value stack: 0: 7 @end verbatim @end lisp To print the contents of the function locals, use @command{wasm-locals}: @lisp @verbatim scheme@(guile-user) [1]> ,wasm-locals Locals: 0: 7 @end verbatim @end lisp To evaluate arbitary Wasm instructions in the current context, either in an attempt to repair interpreter state or just for fun, use @command{wasm-eval}: @lisp @verbatim scheme@(guile-user) [1]> ,wasm-eval '(local.get 0) scheme@(guile-user) [1]> ,wasm-stack Value stack: 0: 7 1: 7 @end verbatim @end lisp There are now two i32 values on the stack. If we were to proceed with execution, the next instruction, @code{i32.add}, should add them together and return a result of 14. To resume execution, use @command{wasm-continue}: @lisp @verbatim scheme@(guile-user) [1]> ,wasm-continue $5 = 14 @end verbatim @end lisp Evaluating arbitrary Wasm commands in a debugging context is very helpful when trying to understand the nature of a bug, but bear in mind that cursed things may happen during the process as there is no validation applied. This goes especially for when you try to resume execution. See @ref{Interpreter} for detailed information on running Wasm within Guile and @ref{Toolchain reference} in general for working with Wasm directly. @deffn {REPL Command} wasm-trace exp Evaluate @var{exp} with verbose Wasm tracing enabled. This will print out every instruction along with the state of the value stack and function locals at the time of evaluation. @end deffn @deffn {REPL Command} wasm-freq exp Evaluate @var{exp} and print out a table showing how many times each kind of Wasm instruction was executed as well as a total instruction count. @end deffn @deffn {REPL Command} wasm-catch exp Catch and debug Wasm runtime errors that are raised by evaluating @var{exp}. @end deffn The following commands are usable only in the context of a Wasm debug REPL: @deffn {REPL Command} wasm-stack Print the state of the Wasm stack. @end deffn @deffn {REPL Command} wasm-locals Print the state of the Wasm function locals. @end deffn @deffn {REPL Command} wasm-pos Print the current function disassembly and highlight the instruction where Wasm execution has paused. @end deffn @deffn {REPL Command} wasm-eval instr Evaluate the Wasm instruction @var{instr} in the current debug context. Use this when attempting to fix the state of the Wasm stack or locals before attempting to resume with @code{,wasm-continue}. @end deffn The following commands behave differently depending on if they are run within a Wasm debug REPL or not. @deffn {REPL Command} wasm-dump [wasm] Display information about @var{wasm}, or the current Wasm instance when debugging. @end deffn @deffn {REPL Command} wasm-continue When in a debugger, exit and resume Wasm execution. In the event that this is run after trapping a runtime error, your warranty is void and all bets are off! While it may be dangerous, this does allow one to manually fix the Wasm interpreter state manually with @code{,wasm-eval} and attempt to proceed, which can come in handy sometimes. When not in a debugger, set the Wasm execution mode to continue without interruption. In other words, deactive the instruction stepper if it is active. @end deffn @deffn {REPL Command} wasm-step When in a debugger, resume Wasm execution but pause before the next instruction is evaluated. When not in a debugger, set Wasm execution to pause before each instruction is evaluated. @end deffn @node Contributing @chapter Contributing Found a bug? Let us know! Made an improvement? Show us! Issues can be filed and pull requests can be submitted on @url{https://codeberg.org/spritely/hoot,Codeberg}. @node License @chapter License @emph{(C) 2023-2025 David Thompson} @emph{Both Guile Hoot and this manual are released under the terms of the following license:} @include apache-2.0.texi @node Index @unnumbered Index @printindex fn @bye guile-hoot-0.7.0/examples/000077500000000000000000000000001507574675700154375ustar00rootroot00000000000000guile-hoot-0.7.0/examples/project-template/000077500000000000000000000000001507574675700207165ustar00rootroot00000000000000guile-hoot-0.7.0/examples/project-template/Makefile000066400000000000000000000001651507574675700223600ustar00rootroot00000000000000hello.wasm: hello.scm guild compile-wasm -L . -o $@ $< serve: hello.wasm guile -c '((@ (hoot web-server) serve))' guile-hoot-0.7.0/examples/project-template/README.md000066400000000000000000000027371507574675700222060ustar00rootroot00000000000000# Hoot example project This directory serves as an example of a basic Hoot project that you can use as a starting point for your own project! It has everything you need: * A simple Scheme program composed of multiple modules that makes use of Web APIs. * A `manifest.scm` file for creating a development environment with `guix shell` * A `Makefile` for compiling the Scheme source to a WebAssembly binary. * HTML and JavaScript files for loading the WebAssembly binary in a web page. * A simple development web server for testing builds. There is one wrinkle in this template: The `reflect.wasm`, `reflect.js`, and `wtf8.wasm` files are symlinks. If you choose to copy this project somewhere as a starting point, you'll want to copy over the necessary files. If you've installed Hoot to your system via `make install` or via a package manager, you'll find all these files in Hoot's `share` directory (such as `/usr/share/guile-hoot`) and can symlink/copy from there. We are looking forward to making this step entirely unnecessary in future releases. ## Building Building this project requires [GNU Guix](https://guix.gnu.org). Once you have Guix, the development environment with all necessary dependencies can be created: ``` guix shell ``` Build the project: ``` make ``` Launch a development web server: ``` make serve ``` To check if the program works, visit https://localhost:8088 in your web browser. We recommend using Mozilla Firefox or Google Chrome at this time. guile-hoot-0.7.0/examples/project-template/hello.js000066400000000000000000000010461507574675700223600ustar00rootroot00000000000000window.addEventListener("load", async () => { try { await Scheme.load_main("hello.wasm", { reflect_wasm_dir: ".", user_imports: { document: { body() { return document.body; }, createTextNode: Document.prototype.createTextNode.bind(document) }, element: { appendChild(parent, child) { return parent.appendChild(child); } } }}); } catch(e) { if(e instanceof WebAssembly.CompileError) { document.getElementById("wasm-error").hidden = false; } } }); guile-hoot-0.7.0/examples/project-template/hello.scm000066400000000000000000000002121507574675700225200ustar00rootroot00000000000000(import (scheme base) (hello document) (hello element)) (append-child! (document-body) (make-text-node "Hello, world!")) guile-hoot-0.7.0/examples/project-template/hello/000077500000000000000000000000001507574675700220215ustar00rootroot00000000000000guile-hoot-0.7.0/examples/project-template/hello/document.scm000066400000000000000000000004641507574675700243470ustar00rootroot00000000000000(library (hello document) (export document-body make-text-node) (import (scheme base) (hoot ffi)) (define-foreign document-body "document" "body" -> (ref null extern)) (define-foreign make-text-node "document" "createTextNode" (ref string) -> (ref null extern))) guile-hoot-0.7.0/examples/project-template/hello/element.scm000066400000000000000000000003341507574675700241560ustar00rootroot00000000000000(library (hello element) (export append-child!) (import (scheme base) (hoot ffi)) (define-foreign append-child! "element" "appendChild" (ref null extern) (ref null extern) -> (ref null extern))) guile-hoot-0.7.0/examples/project-template/index.html000066400000000000000000000007171507574675700227200ustar00rootroot00000000000000 guile-hoot-0.7.0/examples/project-template/manifest.scm000066400000000000000000000003031507574675700232240ustar00rootroot00000000000000(use-modules (guix packages) (gnu packages base) (gnu packages guile) (gnu packages guile-xyz)) (packages->manifest (list guile-next guile-hoot gnu-make)) guile-hoot-0.7.0/examples/project-template/reflect.js000077700000000000000000000000001507574675700273412../../reflect-js/reflect.jsustar00rootroot00000000000000guile-hoot-0.7.0/examples/project-template/reflect.wasm000077700000000000000000000000001507574675700305622../../reflect-wasm/reflect.wasmustar00rootroot00000000000000guile-hoot-0.7.0/examples/project-template/wtf8.wasm000077700000000000000000000000001507574675700272722../../reflect-wasm/wtf8.wasmustar00rootroot00000000000000guile-hoot-0.7.0/examples/repl/000077500000000000000000000000001507574675700164015ustar00rootroot00000000000000guile-hoot-0.7.0/examples/repl/Makefile000066400000000000000000000004041507574675700200370ustar00rootroot00000000000000repl.wasm: repl.scm Makefile ../../pre-inst-env guild compile-wasm -g1 -o $@ $< run-guile: repl.wasm ../../pre-inst-env guile --no-auto-compile boot-repl.scm run-node: repl.wasm node boot-repl.js clean: rm -f repl.wasm .PHONY: clean run-guile run-node guile-hoot-0.7.0/examples/repl/README.md000066400000000000000000000003651507574675700176640ustar00rootroot00000000000000# Hoot REPL example This example demonstrates a text-only REPL suitable for running in either the Hoot Wasm interpreter or NodeJS. ## Try it out Run on the Hoot Wasm interpreter: ``` make run-guile ``` Run on NodeJS: ``` make run-node ``` guile-hoot-0.7.0/examples/repl/boot-repl.js000066400000000000000000000002371507574675700206440ustar00rootroot00000000000000let hoot = await import("../../reflect-js/reflect.js"); let [proc] = await hoot.Scheme.load_main("repl.wasm", { reflect_wasm_dir: "." }); proc.call_async(); guile-hoot-0.7.0/examples/repl/boot-repl.scm000066400000000000000000000003251507574675700210100ustar00rootroot00000000000000(use-modules (hoot reflect) (wasm parse)) (define wasm (call-with-input-file "repl.wasm" parse-wasm)) (define module (hoot-instantiate wasm)) (define proc (hoot-load module)) (hoot-apply-async proc) guile-hoot-0.7.0/examples/repl/reflect.js000077700000000000000000000000001507574675700250242../../reflect-js/reflect.jsustar00rootroot00000000000000guile-hoot-0.7.0/examples/repl/reflect.wasm000077700000000000000000000000001507574675700262452../../reflect-wasm/reflect.wasmustar00rootroot00000000000000guile-hoot-0.7.0/examples/repl/repl.scm000066400000000000000000000071561507574675700200600ustar00rootroot00000000000000;;; Hoot REPL example ;;; Copyright (C) 2025 David Thompson ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; A barebones REPL to demonstrate how to use the interpreter. Input ;;; handling is *very* simplistic; far from a readline quality ;;; experience. ;;; ;;; Code: (use-modules (fibers promises) (fibers streams) (hoot error-handling) (hoot control) (hoot eval) (hoot exceptions) (hoot interaction-environment) (ice-9 match)) (define env (interaction-environment)) (define (run-repl in out) (define (call-with-error-handling thunk) (define tag (make-prompt-tag)) (call-with-prompt tag (lambda () ;; This 5 number is determined empirically to trim the frames ;; within `with-exception-handler`. Terrible! (define outer (+ (stack-height) 5)) (with-exception-handler (lambda (exn) ;; Same, this 2 number is an empirical fudge. Woooo (define stack (capture-stack (stack-height))) (define inner (max (- (vector-length stack) 2) 0)) (define trimmed (vector-copy stack (min outer inner) inner)) (define port (current-error-port)) (define origin (and (exception-with-origin? exn) (exception-origin exn))) (call-with-values (lambda () (if (exception-with-source? exn) (values (exception-source-file exn) (exception-source-line exn) (exception-source-column exn)) (values #f #f #f))) (lambda (file line column) (print-backtrace trimmed origin file line column port port) (display "\nUncaught exception:\n" port) (format-exception exn port) (newline port) (force-output port) (abort-to-prompt tag)))) thunk #:unwind? #f)) (lambda (k) (values)))) (define (display-prompt) (newline out) (display "> " out) (force-output out)) (define (eval* exp) (call-with-error-handling (lambda () (eval exp env)))) (define (print . vals) (for-each (match-lambda ((? unspecified?) (values)) (val (newline out) (display "=> " out) (display val out))) vals)) (display "Welcome to the Hoot REPL!\n\n" out) (display "Press Ctrl-D to quit.\n" out) (let loop () (display-prompt) (match (peek-char in) ((? eof-object?) (values)) (_ (let ((exp (read in))) (call-with-values (lambda () (eval* exp)) print) (loop)))))) (lambda (resolved rejected) (call-with-async-result resolved rejected (lambda () (parameterize ((current-input-port (standard-input-stream)) (current-output-port (standard-output-stream))) (run-repl (current-input-port) (current-output-port)))))) guile-hoot-0.7.0/examples/repl/wtf8.wasm000077700000000000000000000000001507574675700247552../../reflect-wasm/wtf8.wasmustar00rootroot00000000000000guile-hoot-0.7.0/guile000077500000000000000000000000521507574675700146510ustar00rootroot00000000000000#!/bin/sh exec ./pre-inst-env guile "$@" guile-hoot-0.7.0/guix.scm000066400000000000000000000031511507574675700153010ustar00rootroot00000000000000(use-modules (guix) (guix build-system gnu) (guix git) (guix git-download) ((guix licenses) #:prefix license:) (guix packages) (gnu packages autotools) (gnu packages guile) (gnu packages guile-xyz) (gnu packages node) (gnu packages pkg-config) (gnu packages texinfo)) ;; Uncomment and update when we need a fresher Guile than what Guix ;; provides. ;; ;; (define guile-next-next ;; (let ((commit "c8a169d38825d5a21da5392b355ca5fc9f33fa55") ;; (revision "1")) ;; (package ;; (inherit guile-next) ;; (version (git-version "3.0.10" revision commit)) ;; (source ;; (origin ;; (method git-fetch) ;; (uri (git-reference ;; (url "https://codeberg.org/guile/guile.git") ;; (commit commit))) ;; (file-name (git-file-name "guile" version)) ;; (sha256 ;; (base32 "01gqf6c9rnr5l8qralfwq23xmfxbnim1kqppgrd2l42pak3rm9c2"))))))) (package (name "guile-hoot") (version "0.7.0-git") (source (git-checkout (url (dirname (current-filename))))) (build-system gnu-build-system) (arguments '(#:make-flags '("GUILE_AUTO_COMPILE=0"))) (native-inputs (list autoconf automake guile-syntax-highlight pkg-config texinfo)) (inputs (list guile-next node)) (synopsis "WebAssembly compiler for Guile Scheme") (description "Guile-hoot is an ahead-of-time, whole-program WebAssembly compiler for GNU Guile.") (home-page "https://spritely.institute/hoot") (license (list license:asl2.0 license:lgpl3+))) guile-hoot-0.7.0/hoot.ase000066400000000000000000000016031507574675700152640ustar00rootroot00000000000000ƒą„@>dśńd8 ’żś’ęõ’2Cf’}Œ’ņšķ’’żśęõ2Cf}Œņšķ" ’ Background! ’ Character ’Text5 ’@>xœķĮ1Ā õOm ? €·€U ’ +xœu” Ć Deįžg.QSf:ix°(bÖŗ ųė²'ŌŅсĶDšcp'Źģ³“‹°lóZkÖ ļŲ+EYAcžŅEfś*ł­ū|ų¹āšąŲ`É|rģ*“ćį8ó«sĢ æxģ`¢Ņ˜żiłä2:Ø/›ĀŹsź©éé’4gōŽ¼’lé`eęęŻo‹W@©r7G2æĻčęĄ5(ÅqšĘ! Ėc”°Ē¬ų¹yų“9¤’œ.÷[_TņšxÉWuD›ö”Pķń³ Ėī歐pWć”Ēāžū6Wż¬@µÖ1}€ŗ]µ×ćśE²)nu;NiŠ˜q9)bęs¼¬zö)Ņ•sØZ”ŒéŌČēbŁś.`É#üĢÅ,Ņw}˜š ؽ¹MĻOŸ ‘¹ 0’3xœ’I!©Ā’æyXDNćA%q …¤ˆD÷±ńVļ&Ÿü˜Õ’#™„Ųp®ÜĢ¤Ź;³÷zN3@1\±š*ŸX^L³b“«XD¶Bb³Ÿ ČkE¶bœ jb±§^Å ×Z‰’Xü§¢„h*uĶļ Xē×ÄÅS6U½EéyČēœŠĪ»5åy^!ßµy*™'Ņ}’±ÉćŪŚų½Žguile-hoot-0.7.0/hoot.png000066400000000000000000000026611507574675700153050ustar00rootroot00000000000000‰PNG  IHDR@6'5»DPLTE’żśęõ2Cf}ŒņšķŚĆ}„tRNS’’’’Š&RLIDATxœķŪђā6@Ńö’æ9oÕtŃi‰–ƈ¹÷‰Å’‘*ĻĢžśefffffffffū»’tõJ>4aĀ„żß»ūÆĘŻ‹7ż.maĀ„ [²«śżÓą×( & L@Xµ‘!QĀŖŽ‹ é.ĻżČ„ & l:æ«(UŠ ų'aĀ„ 7—+Ž“ŠÕG~nĀ„ pGÕę†uÅŅ¹ż…l‘€0aĀÜ[…5Tl<ćU_ĆÕ{|kĀ„ š|ѐcĪ6, €ć„ F`†ĻnĆ\½Ū7$ L@˜€0Ļ×µK]^|‘€0aĀN¦i ;,& L@XģŗK¹˜>ćź-ļM@˜€0aĀ*‰¹Ųńźń\5D@; & l.VIąķ§łąōŽÕ[Ž›€0aĀ<ߊiŲąpīÕūŽ–€0aĀ<_ģ&!Ģ·v 0Ī½zßŪ& L@˜€°“ĶĘćX¼=7Ÿ‘¾¤«7æ#aĀ„ x¾Ź©R¬ŲŖx®˜ģP@š€0a•]R¬``„s¼jœŃW Ą„ & l8¬q ęwł†£X@˜€0aĀNĪć½Ę]P@€0aøNY.ŁÅē~®¢€0aĀ<_¬<8ŽW‡ÄIÅ%;$ L@X\?…+Ąõ( €ē& ,’NŚ%Å«AV& L@˜€°˜ą°É’€ øœ€0a 0ÄöœĢ ¶xuµÅ©„ & ,‡?Ī{ßQ|īj‹S & L@Xu ’Œ‡ŗ÷Ēnw$ L@˜€0a÷¢ō?.ßb' €& LĄ{ˆ-ÆĀīxu\ŲżP÷ vGĀ„ pGq$ĘOĆ³Ś:ńüš8& L@˜€°˜åuՐ”ńwŁ & L@Ųż¹t §«Q¼Žßjw$ L@˜€0·•e:l»æ|Š»(ą‹„ °WlżQ”ŽŻwpTēl2ŽßÅ & LĄSUl±Ć¹āpÜqæt5Ķć«`Ā„ v{ī1-8ęfouFGW3œO@˜€0aīØrJū%ŁĘą¼zßŪ& L@˜€ē»%‰x/$ŅĆZ¢Lžqēø+ųpJaĀ„ ų†bĆńĻø€éĀ£(}5Õż¾0aĀ„ ųÆw›võź> aĀ„ hfffff¶«ō[ŸįÕK÷ & LĄó0éO’»WÓøŖī ŗs‡ƒ7X_Z'aĀ„ «ˆāž Ą4$5_źŅÜXŚpFw„ ( € ø˜n=\ŚĶ’Żp-ÕßĀuē¦Į ( €īL‹iV+:nnćÜ(<Óąź«P@š-€ii•K1m°17-<}żC“į.P@Ü 8,! WTIģ™[­¾˜o²P@p `µ¢.ąŅÜį8{s‡ćģĶŽ°7w8NĄŽÜį8{sē«oƒ¬^Ą—sē«šåÜłź|9w¾ś’ ąķ9g & L@XZB¬#š#¤åWÓ6Ī%€1c“€ ( €Ļ»I‡Ōp±×$„żļ™;_ż\'¾šŠ ( €ž|zŗõ|•Dõ]Tė%s»ė›oõ$Ų‹» øš€0aīh¾ŌīÕŖīē®Ļķ®Æܽs;aĀ„ ųžWū’å¾ĢRAIEND®B`‚guile-hoot-0.7.0/js-runner/000077500000000000000000000000001507574675700155445ustar00rootroot00000000000000guile-hoot-0.7.0/js-runner/await-call.js000066400000000000000000000045601507574675700201250ustar00rootroot00000000000000var waitFor; if (typeof drainJobQueue !== 'undefined') { waitFor = function waitFor(p) { drainJobQueue(); return p; }; } else { // JSC and V8 will drain promises before exiting and don't require a // specific waiter. waitFor = function waitFor(p) { return p; }; } var args; if (typeof process !== 'undefined') { args = process.argv.slice(3); } else if (typeof scriptArgs !== 'undefined') { args = scriptArgs; } else if (typeof arguments !== 'undefined') { args = arguments; } else { // No script arguments available args = []; } var log; var logErr; if (typeof print !== 'undefined') { log = print; } else if (typeof console !== 'undefined') { log = console.log.bind(console); } if (typeof printErr !== 'undefined') { logErr = printErr; } else { logErr = log; } var _exit; if (typeof quit !== 'undefined') { _exit = quit.bind(this); } else if (typeof testRunner !== 'undefined') { _exit = testRunner.quit.bind(testRunner); } else if (typeof process !== 'undefined') { _exit = process.exit.bind(process); } var _load; if (typeof load !== 'undefined') { _load = load; } else if (typeof require !== 'undefined') { _load = require; } // V8 treats multiple arguments as files, unless -- is given, but // SpiderMonkey doesn't treat -- specially. This is a hack to allow // for -- on SpiderMonkey. if (args[0] == '--') { args.shift(); } if (args.length < 3) { logErr('usage: await-call.js REFLECT_JS_DIR REFLECT_WASM_DIR PROC.WASM ARG.WASM...'); _exit(1); } async function runTest(call, opts) { try { let [procFile, ...argFiles] = call; let [proc] = await Scheme.load_main(procFile, opts); let argPromises = argFiles.map(file => proc.reflector.load_extension(file, opts)); let args = []; for (let p of argPromises) { let [arg] = await p; args.push(arg); } log(repr(await proc.call_async(...args))); } catch (e) { if (e instanceof hoot.SchemeQuitError) { _exit(e.status); } else { log(`error: ${e} (${e.stack})`); _exit(1); } } } var [reflect_js_dir, reflect_wasm_dir, ...test_call] = args; var hoot = _load(`${reflect_js_dir}/reflect.js`); if (typeof hoot !== 'undefined') { Scheme = hoot.Scheme; repr = hoot.repr; } waitFor(runTest(test_call, {reflect_wasm_dir})); guile-hoot-0.7.0/js-runner/call.js000066400000000000000000000046051507574675700170220ustar00rootroot00000000000000var waitFor; if (typeof drainJobQueue !== 'undefined') { waitFor = function waitFor(p) { drainJobQueue(); return p; }; } else { // JSC and V8 will drain promises before exiting and don't require a // specific waiter. waitFor = function waitFor(p) { return p; }; } var args; if (typeof process !== 'undefined') { args = process.argv.slice(3); } else if (typeof scriptArgs !== 'undefined') { args = scriptArgs; } else if (typeof arguments !== 'undefined') { args = arguments; } else { // No script arguments available args = []; } var log; var logErr; if (typeof print !== 'undefined') { log = print; } else if (typeof console !== 'undefined') { log = console.log.bind(console); } if (typeof printErr !== 'undefined') { logErr = printErr; } else { logErr = log; } var _exit; if (typeof quit !== 'undefined') { _exit = quit.bind(this); } else if (typeof testRunner !== 'undefined') { _exit = testRunner.quit.bind(testRunner); } else if (typeof process !== 'undefined') { _exit = process.exit.bind(process); } var _load; if (typeof load !== 'undefined') { _load = load; } else if (typeof require !== 'undefined') { _load = require; } // V8 treats multiple arguments as files, unless -- is given, but // SpiderMonkey doesn't treat -- specially. This is a hack to allow // for -- on SpiderMonkey. if (args[0] == '--') { args.shift(); } if (args.length < 3) { logErr('usage: call.js REFLECT_JS_DIR REFLECT_WASM_DIR PROC.WASM ARG.WASM...'); _exit(1); } async function runTest(call, opts) { try { let [procFile, ...argFiles] = call; let [proc] = await Scheme.load_main(procFile, opts); let argPromises = argFiles.map(file => proc.reflector.load_extension(file, opts)); let args = []; for (let p of argPromises) { let [arg] = await p; args.push(arg); } for (let result of proc.call(...args)) log(repr(result)); } catch (e) { if (e instanceof hoot.SchemeQuitError) { _exit(e.status); } else { log(`error: ${e} (${e.stack})`); _exit(1); } } } var [reflect_js_dir, reflect_wasm_dir, ...test_call] = args; var hoot = _load(`${reflect_js_dir}/reflect.js`); if (typeof hoot !== 'undefined') { Scheme = hoot.Scheme; repr = hoot.repr; } waitFor(runTest(test_call, {reflect_wasm_dir})); guile-hoot-0.7.0/js-runner/load-async.js000066400000000000000000000046531507574675700201440ustar00rootroot00000000000000// -*- js-indent-level: 4 -*- var waitFor; if (typeof drainJobQueue !== 'undefined') { waitFor = function waitFor(p) { drainJobQueue(); return p; }; } else { // JSC and V8 will drain promises before exiting and don't require a // specific waiter. waitFor = function waitFor(p) { return p; }; } var args; if (typeof process !== 'undefined') { args = process.argv.slice(3); } else if (typeof scriptArgs !== 'undefined') { args = scriptArgs; } else if (typeof arguments !== 'undefined') { args = arguments; } else { // No script arguments available args = []; } var log; var logErr; if (typeof print !== 'undefined') { log = print; } else if (typeof console !== 'undefined') { log = console.log.bind(console); } if (typeof printErr !== 'undefined') { logErr = printErr; } else { logErr = log; } var _exit; if (typeof quit !== 'undefined') { _exit = quit.bind(this); } else if (typeof testRunner !== 'undefined') { _exit = testRunner.quit.bind(testRunner); } else if (typeof process !== 'undefined') { _exit = process.exit.bind(process); } var _load; if (typeof load !== 'undefined') { _load = load; } else if (typeof require !== 'undefined') { _load = require; } // V8 treats multiple arguments as files, unless -- is given, but // SpiderMonkey doesn't treat -- specially. This is a hack to allow // for -- on SpiderMonkey. if (args[0] == '--') { args.shift(); } if ((args.length < 3) || (args.length > 4)) { logErr('usage: load.js REFLECT_JS_DIR REFLECT_WASM_DIR FOO.WASM [USER_IMPORTS]'); _exit(1); } async function runTest(wasmFile, opts) { try { let [proc] = await Scheme.load_main(wasmFile, opts); log(repr(await proc.call_async())); } catch (e) { if (e instanceof hoot.SchemeQuitError) { _exit(e.status); } else { log(`error: ${e} (${e.stack})`); _exit(1); } } } var [reflect_js_dir, reflect_wasm_dir, test_wasm, user_imports_file] = args; var hoot = _load(`${reflect_js_dir}/reflect.js`); if (typeof hoot !== 'undefined') { Scheme = hoot.Scheme; repr = hoot.repr; } var user_imports = {}; if (user_imports_file) { user_imports = _load(user_imports_file).user_imports; if (typeof user_imports === 'undefined') { logErr(`user imports file ${user_imports_file} failed to load`); _exit(1); } } waitFor(runTest(test_wasm, {reflect_wasm_dir, user_imports})); guile-hoot-0.7.0/js-runner/load-primitive.js000066400000000000000000000045411507574675700210330ustar00rootroot00000000000000var waitFor; if (typeof drainJobQueue !== 'undefined') { waitFor = function waitFor(p) { drainJobQueue(); return p; }; } else { // JSC and V8 will drain promises before exiting and don't require a // specific waiter. waitFor = function waitFor(p) { return p; }; } var args; if (typeof process !== 'undefined') { args = process.argv.slice(3); } else if (typeof scriptArgs !== 'undefined') { args = scriptArgs; } else if (typeof arguments !== 'undefined') { args = arguments; } else { // No script arguments available args = []; } var log; var logErr; if (typeof print !== 'undefined') { log = print; } else if (typeof console !== 'undefined') { log = console.log.bind(console); } if (typeof printErr !== 'undefined') { logErr = printErr; } else { logErr = log; } var _exit; if (typeof quit !== 'undefined') { _exit = quit.bind(this); } else if (typeof testRunner !== 'undefined') { _exit = testRunner.quit.bind(testRunner); } else if (typeof process !== 'undefined') { _exit = process.exit.bind(process); } // V8 treats multiple arguments as files, unless -- is given, but // SpiderMonkey doesn't treat -- specially. This is a hack to allow // for -- on SpiderMonkey. if (args[0] == '--') { args.shift(); } if (args.length < 2) { logErr('usage: load-primitive.js FOO.WASM FUNC [ARGS ...]'); _exit(1); } async function instantiateStreaming(path, imports) { if (typeof fetch !== 'undefined' && typeof window !== 'undefined') return WebAssembly.instantiateStreaming(fetch(path), imports); let bytes; if (typeof read !== 'undefined') { bytes = read(path, 'binary'); } else if (typeof readFile !== 'undefined') { bytes = readFile(path); } else { let fs = require('fs'); bytes = fs.readFileSync(path); } return WebAssembly.instantiate(bytes, imports); } async function compileAndRun(wasmFile, funcName, args) { const imports = {}; const { module, instance } = await instantiateStreaming(wasmFile, imports); const f = instance.exports[funcName]; return f.apply(null, args); } async function runTest(wasmFile, funcName, ...args) { const parsedArgs = args.map(JSON.parse); try { const result = await compileAndRun(wasmFile, funcName, parsedArgs); log(result.toString()); } catch (e) { log(`error: ${e} (${e.stack})`); _exit(1); } } waitFor(runTest.apply(null, args)); guile-hoot-0.7.0/js-runner/load.js000066400000000000000000000046361507574675700170320ustar00rootroot00000000000000// -*- js-indent-level: 4 -*- var waitFor; if (typeof drainJobQueue !== 'undefined') { waitFor = function waitFor(p) { drainJobQueue(); return p; }; } else { // JSC and V8 will drain promises before exiting and don't require a // specific waiter. waitFor = function waitFor(p) { return p; }; } var args; if (typeof process !== 'undefined') { args = process.argv.slice(3); } else if (typeof scriptArgs !== 'undefined') { args = scriptArgs; } else if (typeof arguments !== 'undefined') { args = arguments; } else { // No script arguments available args = []; } var log; var logErr; if (typeof print !== 'undefined') { log = print; } else if (typeof console !== 'undefined') { log = console.log.bind(console); } if (typeof printErr !== 'undefined') { logErr = printErr; } else { logErr = log; } var _exit; if (typeof quit !== 'undefined') { _exit = quit.bind(this); } else if (typeof testRunner !== 'undefined') { _exit = testRunner.quit.bind(testRunner); } else if (typeof process !== 'undefined') { _exit = process.exit.bind(process); } var _load; if (typeof load !== 'undefined') { _load = load; } else if (typeof require !== 'undefined') { _load = require; } // V8 treats multiple arguments as files, unless -- is given, but // SpiderMonkey doesn't treat -- specially. This is a hack to allow // for -- on SpiderMonkey. if (args[0] == '--') { args.shift(); } if ((args.length < 3) || (args.length > 4)) { logErr('usage: load.js REFLECT_JS_DIR REFLECT_WASM_DIR FOO.WASM [USER_IMPORTS]'); _exit(1); } async function runTest(wasmFile, opts) { try { for (let obj of await Scheme.load_main(wasmFile, opts)) log(repr(obj)); } catch (e) { if (e instanceof hoot.SchemeQuitError) { _exit(e.status); } else { log(`error: ${e} (${e.stack})`); _exit(1); } } } var [reflect_js_dir, reflect_wasm_dir, test_wasm, user_imports_file] = args; var hoot = _load(`${reflect_js_dir}/reflect.js`); if (typeof hoot !== 'undefined') { Scheme = hoot.Scheme; repr = hoot.repr; } var user_imports = {}; if (user_imports_file) { user_imports = _load(user_imports_file).user_imports; if (typeof user_imports === 'undefined') { logErr(`user imports file ${user_imports_file} failed to load`); _exit(1); } } waitFor(runTest(test_wasm, {reflect_wasm_dir, user_imports})); guile-hoot-0.7.0/lib/000077500000000000000000000000001507574675700143675ustar00rootroot00000000000000guile-hoot-0.7.0/lib/Makefile.am000066400000000000000000000057161507574675700164340ustar00rootroot00000000000000SOURCES = \ fibers.scm \ fibers/channels.scm \ fibers/conditions.scm \ fibers/operations.scm \ fibers/promises.scm \ fibers/scheduler.scm \ fibers/streams.scm \ fibers/timers.scm \ fibers/waiter-queue.scm \ guile.scm \ hoot/apply.scm \ hoot/assoc.scm \ hoot/atomics.scm \ hoot/bitvectors.scm \ hoot/bitwise.scm \ hoot/boxes.scm \ hoot/bytevectors.scm \ hoot/char.scm \ hoot/cond-expand.scm \ hoot/control.scm \ hoot/core-syntax.scm \ hoot/core-syntax-helpers.scm \ hoot/cross-compilation.scm \ hoot/debug.scm \ hoot/dynamic-states.scm \ hoot/dynamic-wind.scm \ hoot/environments.scm \ hoot/eq.scm \ hoot/equal.scm \ hoot/error-handling.scm \ hoot/errors.scm \ hoot/eval.scm \ hoot/exceptions.scm \ hoot/expander.scm \ hoot/external.scm \ hoot/ffi.scm \ hoot/finalization.scm \ hoot/fluids.scm \ hoot/gensym.scm \ hoot/hackable.scm \ hoot/hashtables.scm \ hoot/inline-wasm.scm \ hoot/interaction-environment.scm \ hoot/keywords.scm \ hoot/lists.scm \ hoot/match.scm \ hoot/modules.scm \ hoot/not.scm \ hoot/numbers.scm \ hoot/pairs.scm \ hoot/parameters.scm \ hoot/ports.scm \ hoot/primitive-eval.scm \ hoot/primitives-module.scm \ hoot/procedures.scm \ hoot/read.scm \ hoot/records.scm \ hoot/regexps.scm \ hoot/strings.scm \ hoot/symbols.scm \ hoot/syntax.scm \ hoot/syntax-objects.scm \ hoot/syntax-transformers.scm \ hoot/time.scm \ hoot/tree-il.scm \ hoot/values.scm \ hoot/vectors.scm \ hoot/weak-refs.scm \ hoot/weak-vectors.scm \ hoot/write.scm \ ice-9/atomic.scm \ ice-9/binary-ports.scm \ ice-9/control.scm \ ice-9/custom-ports.scm \ ice-9/exceptions.scm \ ice-9/i18n.scm \ ice-9/match.scm \ ice-9/optargs.scm \ ice-9/ports/internal.scm \ ice-9/rdelim.scm \ ice-9/regex.scm \ ice-9/weak-vector.scm \ rnrs/bytevectors.scm \ rnrs/bytevectors/gnu.scm \ scheme/base.scm \ scheme/case-lambda.scm \ scheme/char.scm \ scheme/complex.scm \ scheme/cxr.scm \ scheme/eval.scm \ scheme/file.scm \ scheme/inexact.scm \ scheme/lazy.scm \ scheme/load.scm \ scheme/process-context.scm \ scheme/r5rs.scm \ scheme/read.scm \ scheme/repl.scm \ scheme/time.scm \ scheme/write.scm \ srfi/srfi-9.scm \ srfi/srfi-9/gnu.scm \ srfi/srfi-11.scm \ srfi/srfi-14.scm GENERATED_SOURCES = \ hoot/char-prelude.scm hoot/char-prelude.scm: $(top_srcdir)/bin/generate-char-prelude.scm $(AM_V_GEN)$(MKDIR_P) $(dir $@) && \ $(top_builddir)/pre-inst-env $(GUILE) $< > "$@" CLEANFILES = $(GENERATED_SOURCES) EXTRA_DIST = $(SOURCES) moddir=$(pkgdatadir)/$(PACKAGE_VERSION)/lib nobase_mod_DATA = $(SOURCES) $(GENERATED_SOURCES) guile-hoot-0.7.0/lib/fibers.scm000066400000000000000000000023331507574675700163460ustar00rootroot00000000000000;;; Hoot implementation of Fibers ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. (define-module (fibers) #:use-module (fibers scheduler) #:use-module (fibers timers) #:export (spawn-fiber) #:re-export (sleep)) (define (spawn-fiber thunk) "Spawn a new fiber which will start by invoking @var{thunk}. The fiber will be scheduled on the next turn. @var{thunk} will run with a copy of the current dynamic state, isolating fluid and parameter mutations to the fiber." (define (capture-dynamic-state thunk) (let ((dynamic-state (current-dynamic-state))) (lambda () (with-dynamic-state dynamic-state thunk)))) (schedule-task (capture-dynamic-state thunk))) guile-hoot-0.7.0/lib/fibers/000077500000000000000000000000001507574675700156415ustar00rootroot00000000000000guile-hoot-0.7.0/lib/fibers/channels.scm000066400000000000000000000055501507574675700201450ustar00rootroot00000000000000;;; Hoot implementation of Fibers ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. (define-module (fibers channels) #:use-module (srfi srfi-9) #:use-module (ice-9 match) #:use-module (fibers waiter-queue) #:use-module (fibers operations) #:export (make-channel channel? put-operation get-operation put-message get-message)) (define-record-type (%make-channel getq putq) channel? (getq channel-getq) (putq channel-putq)) (define (make-channel) "Make a fresh channel." (%make-channel (make-waiter-queue) (make-waiter-queue))) (define (put-operation channel message) "Make an operation that if and when it completes will rendezvous with a receiver fiber to send @var{message} over @var{channel}." (match channel (($ getq putq) (define (try-fn) (match (waiter-queue-pop! getq #f) (#f #f) (resume-get (resume-get (lambda () message)) (lambda () (values))))) (define (block-fn state resume-put) (waiter-queue-push! putq state (cons resume-put message)) (values)) (make-base-operation #f try-fn block-fn)))) (define (get-operation channel) "Make an operation that if and when it completes will rendezvous with a sender fiber to receive one value from @var{channel}." (match channel (($ getq putq) (define (try-fn) (match (waiter-queue-pop! putq #f) (#f #f) ((resume-put . message) (resume-put (lambda () (values))) (lambda () message)))) (define (block-fn state resume-get) (waiter-queue-push! getq state resume-get) (values)) (make-base-operation #f try-fn block-fn)))) (define (put-message channel message) "Send @var{message} on @var{channel}, and return zero values. If there is already another fiber waiting to receive a message on this channel, give it our message and continue. Otherwise, block until a receiver becomes available." (perform-operation (put-operation channel message))) (define (get-message channel) "Receive a message from @var{channel} and return it. If there is already another fiber waiting to send a message on this channel, take its message directly. Otherwise, block until a sender becomes available." (perform-operation (get-operation channel))) guile-hoot-0.7.0/lib/fibers/conditions.scm000066400000000000000000000042021507574675700205140ustar00rootroot00000000000000;;; Hoot implementation of Fibers ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. (define-module (fibers conditions) #:use-module (srfi srfi-9) #:use-module (ice-9 match) #:use-module (fibers waiter-queue) #:use-module (fibers operations) #:export (make-condition condition? signal-condition! wait-operation wait)) (define-record-type (%make-condition signalled? waiters) condition? (signalled? condition-signalled? set-condition-signalled?!) (waiters condition-waiters)) (define (make-condition) "Make a fresh condition variable." (%make-condition #f (make-waiter-queue))) (define (signal-condition! cvar) "Mark @var{cvar} as having been signalled. Resume any fiber or thread waiting for @var{cvar}. If @var{cvar} is already signalled, calling @code{signal-condition!} does nothing and returns @code{#f}; returns @code{#t} otherwise." (match cvar (($ #f waiters) (set-condition-signalled?! cvar #t) (waiter-queue-pop-all! waiters (lambda (resume) (resume values))) #t) (($ ) #f))) (define (wait-operation cvar) "Make an operation that will complete when @var{cvar} is signalled." (match cvar (($ _ waiters) (define (try-fn) (and (condition-signalled? cvar) (lambda () (values)))) (define (block-fn state resume) (waiter-queue-push! waiters state resume) (values)) (make-base-operation #f try-fn block-fn)))) (define (wait cvar) "Wait until @var{cvar} has been signalled." (perform-operation (wait-operation cvar))) guile-hoot-0.7.0/lib/fibers/operations.scm000066400000000000000000000124761507574675700205420ustar00rootroot00000000000000;;; Hoot implementation of Fibers ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; A port of the Concurrent ML implementation from ;;; https://github.com/wingo/fibers and ;;; https://github.com/snabbco/snabb/blob/master/src/lib/fibers/op.lua. ;;; Unlike the CML in Guile's Fibers, this implementation is not ;;; parallel, so it can be much more simple, and it relies on a default ;;; prompt handler being in place instead of an explicit run-fibers. ;;; ;;; Unlike the CML in Snabb's fibers, this implementation handles ;;; multiple values. ;;; (define-module (fibers operations) #:use-module (hoot boxes) #:use-module (srfi srfi-9) #:use-module (ice-9 match) #:use-module (fibers scheduler) #:export (op-state-completed? op-state-complete! wrap-operation choice-operation perform-operation make-base-operation)) ;; Two possible values: #f (waiting), or #t (completed). (define (make-op-state) (make-box #f)) (define (op-state-completed? state) (box-ref state)) (define (op-state-complete! state) (let ((prev (op-state-completed? state))) (box-set! state #t) (not prev))) (define-record-type (make-base-operation wrap-fn try-fn block-fn) base-op? ;; ((arg ...) -> (result ...)) | #f (wrap-fn base-op-wrap-fn) ;; () -> (thunk | #f) (try-fn base-op-try-fn) ;; (op-state resume-k) -> () (block-fn base-op-block-fn)) (define-record-type (make-choice-operation base-ops) choice-op? (base-ops choice-op-base-ops)) (define (wrap-operation op f) "Given the operation @var{op}, return a new operation that, if and when it succeeds, will apply @var{f} to the values yielded by performing @var{op}, and yield the result as the values of the wrapped operation." (match op (($ wrap-fn try-fn block-fn) (make-base-operation (match wrap-fn (#f f) (_ (lambda args (call-with-values (lambda () (apply wrap-fn args)) f)))) try-fn block-fn)) (($ base-ops) (let* ((count (vector-length base-ops)) (base-ops* (make-vector count))) (let lp ((i 0)) (when (< i count) (vector-set! base-ops* i (wrap-operation (vector-ref base-ops i) f)) (lp (1+ i)))) (make-choice-operation base-ops*))))) (define (choice-operation . ops) "Given the operations @var{ops}, return a new operation that if it succeeds, will succeed with one and only one of the sub-operations @var{ops}." (define (flatten ops) (match ops (() '()) ((op . ops) (append (match op (($ ) (list op)) (($ base-ops) (vector->list base-ops))) (flatten ops))))) (match (flatten ops) ((base-op) base-op) (base-ops (make-choice-operation (list->vector base-ops))))) (define (random n) ;; FIXME!!! 0) (define (perform-operation op) "Perform the operation @var{op} and return the resulting values. If the operation cannot complete directly, block until it can complete." (define (wrap-resume resume wrap-fn) (if wrap-fn (lambda (thunk) (resume (lambda () (call-with-values thunk wrap-fn)))) resume)) (define (block resume) (let ((state (make-op-state))) (match op (($ wrap-fn try-fn block-fn) (block-fn state (wrap-resume resume wrap-fn))) (($ base-ops) (let lp ((i 0)) (when (< i (vector-length base-ops)) (match (vector-ref base-ops i) (($ wrap-fn try-fn block-fn) (block-fn state (wrap-resume resume wrap-fn)))) (lp (1+ i)))))))) (define (suspend) ((suspend-current-task (lambda (k) (define (resume thunk) (schedule-task (lambda () (k thunk)))) (block resume))))) ;; First, try to sync on an op. If no op syncs, block. (match op (($ wrap-fn try-fn) (match (try-fn) (#f (suspend)) (thunk (if wrap-fn (call-with-values thunk wrap-fn) (thunk))))) (($ base-ops) (let* ((count (vector-length base-ops)) (offset (random count))) (let lp ((i 0)) (if (< i count) (match (vector-ref base-ops (modulo (+ i offset) count)) (($ wrap-fn try-fn) (match (try-fn) (#f (lp (1+ i))) (thunk (if wrap-fn (call-with-values thunk wrap-fn) (thunk)))))) (suspend))))))) guile-hoot-0.7.0/lib/fibers/promises.scm000066400000000000000000000052231507574675700202100ustar00rootroot00000000000000;;; Hoot implementation of Fibers ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. (define-module (fibers promises) #:use-module (fibers operations) #:use-module (hoot ffi) #:use-module ((hoot exceptions) #:select (make-exception-with-message make-exception-with-origin make-exception-with-irritants define-exception-type)) #:export (await-promise-operation await call-with-async-result)) (define-foreign promise:on-completed "rt" "promise_on_completed" (ref extern) (ref extern) (ref extern) -> none) (define-foreign promise:complete! "rt" "promise_complete" (ref extern) (ref eq) -> none) (define-exception-type &promise-failure &error make-promise-failure promise-failure?) (define (promise-failure val) (make-exception (make-promise-failure) (make-exception-with-message "promise was rejected") (make-exception-with-origin 'await-promise-operation) (make-exception-with-irritants (list val)))) (define (await-promise-operation promise) "Make an operation that will complete when @var{promise} is resolved. Performing the operation produces one value: a thunk which when called will either return the value or throw an exception." (define (try-fn) #f) (define (block-fn state resume) (promise:on-completed promise (procedure->external (lambda (x) (when (op-state-complete! state) (resume (lambda () (lambda () x)))))) (procedure->external (lambda (err) (when (op-state-complete! state) (resume (lambda () (raise-exception (promise-failure err)))))))) (values)) (make-base-operation #f try-fn block-fn)) (define (await promise) ((perform-operation (await-promise-operation promise)))) (define (call-with-async-result resolved rejected thunk) (with-exception-handler (lambda (err) (promise:complete! rejected err)) (lambda () (call-with-values thunk (lambda vals (promise:complete! resolved vals)))) #:unwind? #t)) guile-hoot-0.7.0/lib/fibers/scheduler.scm000066400000000000000000000022401507574675700203210ustar00rootroot00000000000000;;; Hoot implementation of Fibers ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. (define-module (fibers scheduler) #:use-module (hoot ffi) #:export (schedule-task suspend-current-task)) (define-foreign %async-invoke "rt" "async_invoke" (ref extern) -> none) (define-foreign %async-invoke-later "rt" "async_invoke_later" (ref extern) f64 -> none) (define schedule-task (case-lambda ((thunk) (%async-invoke (procedure->external thunk))) ((thunk delay) (%async-invoke-later (procedure->external thunk) delay)))) (define (suspend-current-task handler) (abort-to-prompt (default-prompt-tag) handler)) guile-hoot-0.7.0/lib/fibers/streams.scm000066400000000000000000000125461507574675700200330ustar00rootroot00000000000000;;; Streams ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Streams are host objects that are asynchronous sources or sinks of ;;; data. This module wraps streams in the Hoot port interface, as ;;; input or output ports. Although the interface with the host is ;;; somewhat abstract, it is modelled after the WhatWG Streams ;;; specification (https://streams.spec.whatwg.org/). ;;; ;;; The Streams API is somewhat vague as to what constitutes "data". ;;; For our purposes, we assume that each chunk of data is a byte array. ;;; Encoding/decoding text is the host's responsibility, if that is what ;;; is wanted. ;;; ;;; Code: (define-module (fibers streams) #:use-module (hoot ports) #:use-module (hoot ffi) #:use-module (fibers promises) #:use-module (hoot bytevectors) #:export (open-input-stream open-output-stream standard-input-stream standard-output-stream standard-error-stream)) ;; length -> Uint8Array (define-foreign stream:make-chunk "rt" "stream_make_chunk" i32 -> (ref extern)) ;; Uint8Array -> length (define-foreign stream:chunk-length "rt" "stream_chunk_length" (ref extern) -> i32) ;; Uint8Array, idx -> byte (define-foreign stream:chunk-ref "rt" "stream_chunk_ref" (ref extern) i32 -> i32) ;; Uint8Array, idx, byte -> () (define-foreign stream:chunk-set! "rt" "stream_chunk_set" (ref extern) i32 i32 -> none) ;; ReadableStream -> ReadableStreamDefaultReader (define-foreign stream:get-reader "rt" "stream_get_reader" (ref extern) -> (ref extern)) ;; ReadableStreamDefaultReader -> Promise> (define-foreign stream:read "rt" "stream_read" (ref extern) -> (ref extern)) ;; Result -> Uint8Array (define-foreign stream:result-chunk "rt" "stream_result_chunk" (ref extern) -> (ref extern)) ;; Result -> 1 if done, 0 otherwise (define-foreign stream:result-done? "rt" "stream_result_done" (ref extern) -> i32) ;; WritableStream -> WritableStreamDefaultWriter (define-foreign stream:get-writer "rt" "stream_get_writer" (ref extern) -> (ref extern)) ;; WritableStreamDefaultWriter, Uint8Array -> Promise (define-foreign stream:write "rt" "stream_write" (ref extern) (ref extern) -> (ref extern)) ;; WritableStreamDefaultWriter -> Promise (define-foreign stream:close-writer "rt" "stream_close_writer" (ref extern) -> (ref extern)) ;; -> ReadableStream (define-foreign stream:stdin "io" "stream_stdin" -> (ref extern)) ;; -> WritableStream (define-foreign stream:stdout "io" "stream_stdout" -> (ref extern)) ;; -> WritableStream (define-foreign stream:stderr "io" "stream_stderr" -> (ref extern)) (define (open-input-stream stream) (define reader (stream:get-reader stream)) (define did-read 0) (define pos 0) (define done? #f) (define chunk #f) (define chunk-len 0) (define (read dst start count) (cond ((eq? pos chunk-len) (if done? 0 (let ((result (await (stream:read reader)))) (set! done? (not (zero? (stream:result-done? result)))) (set! did-read (+ did-read chunk-len)) (set! chunk (if done? #f (stream:result-chunk result))) (set! pos 0) (set! chunk-len (if done? 0 (stream:chunk-length chunk))) (read dst start count)))) (else (let ((to-copy (min count (- chunk-len pos)))) (let lp ((i 0)) (when (< i to-copy) (bytevector-u8-set! dst (+ start i) (stream:chunk-ref chunk (+ pos i))) (lp (1+ i)))) (set! pos (+ pos to-copy)) to-copy)))) (define (seek offset whence) ; seek (if (and (zero? offset) (eq? whence 'cur)) (+ did-read pos) (error "unreachable; stream ports are not seekable"))) (make-port #:read read #:seek seek #:repr "stream")) (define (open-output-stream stream) (define writer (stream:get-writer stream)) (define pos 0) (define (write bv start count) (unless (zero? count) (let ((chunk (stream:make-chunk count))) (let lp ((i 0)) (when (< i count) (stream:chunk-set! chunk i (bytevector-u8-ref bv (+ start i))) (lp (1+ i)))) (await (stream:write writer chunk)))) (set! pos (+ pos count)) count) (define (seek offset whence) (if (and (zero? offset) (eq? whence 'cur)) pos (error "unreachable; stream ports are not seekable"))) (define (close) (stream:close-writer writer)) (make-port #:write write #:seek seek #:close close #:repr "stream")) (define (standard-input-stream) (open-input-stream (stream:stdin))) (define (standard-output-stream) (open-output-stream (stream:stdout))) (define (standard-error-stream) (open-output-stream (stream:stderr))) guile-hoot-0.7.0/lib/fibers/timers.scm000066400000000000000000000034271507574675700176560ustar00rootroot00000000000000;;; Hoot implementation of Fibers ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. (define-module (fibers timers) #:use-module (fibers scheduler) #:use-module (fibers operations) #:use-module (scheme time) #:export (sleep-operation timer-operation sleep)) (define (timer-operation expiry) "Make an operation that will succeed when the current time is greater than or equal to @var{expiry}, expressed in internal time units. The operation will succeed with no values." (define (try-fn) (and (< expiry (current-jiffy)) (lambda () (values)))) (define (block-fn state resume) (schedule-task (lambda () (when (op-state-complete! state) (resume (lambda () (values))))) (max 0 (- expiry (current-jiffy))))) (make-base-operation #f try-fn block-fn)) (define (sleep-operation seconds) "Make an operation that will succeed with no values when @var{seconds} have elapsed." (define expiry (+ (current-jiffy) (inexact->exact (round (* seconds (jiffies-per-second)))))) (timer-operation expiry)) (define (sleep seconds) "Block the calling fiber until @var{seconds} have elapsed." (perform-operation (sleep-operation seconds))) guile-hoot-0.7.0/lib/fibers/waiter-queue.scm000066400000000000000000000054101507574675700207620ustar00rootroot00000000000000;;; Hoot implementation of Fibers ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. (define-module (fibers waiter-queue) #:use-module (srfi srfi-9) #:use-module (ice-9 match) #:use-module (fibers operations) #:export (make-waiter-queue waiter-queue-push! waiter-queue-pop! waiter-queue-pop-all!)) (define-record-type (%make-waiter-queue head) waiter-queue? (head waiter-queue-head set-waiter-queue-head!)) (define (make-waiter-queue) (%make-waiter-queue '())) ;; Push an item on the back of the queue, removing any entries for ;; completed operations. (define (waiter-queue-push! q op-state data) (match q (($ head) (let ((new-tail (acons op-state data '()))) (let drop-head ((head head)) (match head (() ;; New tail is the only entry on the queue. (set-waiter-queue-head! q new-tail) (values)) ((((? op-state-completed?) . _) . head*) ;; Queue head is completed already; pop it off. (drop-head head*)) ((_ . tail) ;; Found a pending waiter on the queue. Filter out any ;; other completed operations and tack the new tail on the ;; back. (set-waiter-queue-head! q head) (let filter-tail ((prev head) (tail tail)) (match tail (() (set-cdr! prev new-tail) (values)) ((((? op-state-completed?) . _) . tail*) (set-cdr! prev tail*) (filter-tail prev tail*)) ((_ . tail*) (filter-tail tail tail*))))))))))) (define* (waiter-queue-pop! q #:optional empty) (match (waiter-queue-head q) (() empty) (((op-state . data) . tail) (set-waiter-queue-head! q tail) (if (op-state-complete! op-state) data (waiter-queue-pop! q empty))))) (define (waiter-queue-pop-all! q proc) (let ((elts (waiter-queue-head q))) (set-waiter-queue-head! q '()) (for-each (match-lambda ((op-state . data) (when (op-state-complete! op-state) (proc data)))) elts) (values))) guile-hoot-0.7.0/lib/guile.scm000066400000000000000000002143431507574675700162070ustar00rootroot00000000000000;;; Copyright (C) 2024, 2025 Igalia, S.L. ;;; Copyright (C) 2024 David Thompson ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Shim to implement Guile API on top of Hoot. ;;; ;;; Code: ;; bindings not supported: #; (define *unimplemented-bindings '($sc-dispatch %auto-compilation-options %char-set-dump %compile-fallback-path %cond-expand-features %cond-expand-table %expanded-vtables %file-port-name-canonicalization %fresh-auto-compile %get-pre-modules-obarray %get-stack-size %global-site-dir %guile-build-info %host-type %init-rdelim-builtins %init-rw-builtins %library-dir %load-announce %load-compiled-extensions %load-compiled-path %load-extensions %load-hook %load-path %load-should-auto-compile %load-verbosely %package-data-dir %port-property %print-module %read-hash-procedures %resolve-variable %search-load-path %set-port-property! %site-ccache-dir %site-dir %stacks %start-stack %string-dump %symbol-dump %warn-auto-compilation-enabled &exception-with-kind-and-args &programming-error &quit-exception *features* *null-device* *random-state* *repl-stack* ->char-set @ AF_INET AF_INET6 AF_UNIX AF_UNSPEC AI_ADDRCONFIG AI_ALL AI_CANONNAME AI_NUMERICHOST AI_NUMERICSERV AI_PASSIVE AI_V4MAPPED AT_EACCESS AT_EMPTY_PATH AT_NO_AUTOMOUNT AT_REMOVEDIR AT_SYMLINK_FOLLOW AT_SYMLINK_NOFOLLOW E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EADV EAFNOSUPPORT EAGAIN EAI_ADDRFAMILY EAI_AGAIN EAI_ALLDONE EAI_BADFLAGS EAI_CANCELED EAI_FAIL EAI_FAMILY EAI_IDN_ENCODE EAI_INPROGRESS EAI_INTR EAI_MEMORY EAI_NODATA EAI_NONAME EAI_NOTCANCELED EAI_OVERFLOW EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM EALREADY EBADE EBADF EBADFD EBADMSG EBADR EBADRQC EBADSLT EBFONT EBUSY ECANCELED ECHILD ECHRNG ECOMM ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDEADLOCK EDESTADDRREQ EDOM EDOTDOT EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EHWPOISON EIDRM EILSEQ EINPROGRESS EINTR EINVAL EIO EISCONN EISDIR EISNAM EKEYEXPIRED EKEYREJECTED EKEYREVOKED EL2HLT EL2NSYNC EL3HLT EL3RST ELIBACC ELIBBAD ELIBEXEC ELIBMAX ELIBSCN ELNRNG ELOOP EMEDIUMTYPE EMFILE EMLINK EMSGSIZE EMULTIHOP ENAMETOOLONG ENAVAIL ENETDOWN ENETRESET ENETUNREACH ENFILE ENOANO ENOBUFS ENOCSI ENODATA ENODEV ENOENT ENOEXEC ENOKEY ENOLCK ENOLINK ENOMEDIUM ENOMEM ENOMSG ENONET ENOPKG ENOPROTOOPT ENOSPC ENOSR ENOSTR ENOSYS ENOTBLK ENOTCONN ENOTDIR ENOTEMPTY ENOTNAM ENOTRECOVERABLE ENOTSOCK ENOTSUP ENOTTY ENOTUNIQ ENXIO EOPNOTSUPP EOVERFLOW EOWNERDEAD EPERM EPFNOSUPPORT EPIPE EPROTO EPROTONOSUPPORT EPROTOTYPE ERANGE EREMCHG EREMOTE EREMOTEIO ERESTART ERFKILL EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESRMNT ESTALE ESTRPIPE ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUCLEAN EUNATCH EUSERS EWOULDBLOCK EXDEV EXFULL EXIT_FAILURE EXIT_SUCCESS FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETOWN F_OK F_SETFD F_SETFL F_SETOWN IN6ADDR_ANY IN6ADDR_LOOPBACK INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE IPPROTO_IP IPPROTO_IPV6 IPPROTO_TCP IPPROTO_UDP IPV6_V6ONLY IP_ADD_MEMBERSHIP IP_DROP_MEMBERSHIP IP_MULTICAST_IF IP_MULTICAST_TTL ITIMER_PROF ITIMER_REAL ITIMER_VIRTUAL LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER LC_TELEPHONE LC_TIME LOCK_EX LOCK_NB LOCK_SH LOCK_UN MSG_DONTROUTE MSG_DONTWAIT MSG_OOB MSG_PEEK NSIG OPEN_BOTH OPEN_READ OPEN_WRITE O_APPEND O_ASYNC O_CLOEXEC O_CREAT O_DIRECT O_DIRECTORY O_EXCL O_IGNORE_CTTY O_LARGEFILE O_NDELAY O_NOATIME O_NOCTTY O_NOFOLLOW O_NOLINK O_NONBLOCK O_NOTRANS O_PATH O_RDONLY O_RDWR O_SYNC O_TMPFILE O_TRUNC O_WRONLY PF_INET PF_INET6 PF_UNIX PF_UNSPEC PIPE_BUF PRIO_PGRP PRIO_PROCESS PRIO_USER R_OK SA_NOCLDSTOP SA_RESTART SEEK_DATA SEEK_HOLE SIGABRT SIGALRM SIGBUS SIGCHLD SIGCLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGIO SIGIOT SIGKILL SIGPIPE SIGPOLL SIGPROF SIGPWR SIGQUIT SIGRTMAX SIGRTMIN SIGSEGV SIGSTKFLT SIGSTKSZ SIGSTOP SIGSYS SIGTERM SIGTRAP SIGTSTP SIGTTIN SIGTTOU SIGURG SIGUSR1 SIGUSR2 SIGVTALRM SIGWINCH SIGXCPU SIGXFSZ SIG_DFL SIG_IGN SOCK_CLOEXEC SOCK_DGRAM SOCK_NONBLOCK SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM SOL_SOCKET SO_BROADCAST SO_DEBUG SO_DONTROUTE SO_ERROR SO_KEEPALIVE SO_LINGER SO_NO_CHECK SO_OOBINLINE SO_PRIORITY SO_RCVBUF SO_RCVTIMEO SO_REUSEADDR SO_REUSEPORT SO_SNDBUF SO_SNDTIMEO SO_TYPE TCP_CORK TCP_NODELAY WAIT_ANY WAIT_MYPGRP WNOHANG WUNTRACED W_OK X_OK abort-hook abort-to-prompt* absolute-file-name? accept access? acosh add-hook! add-to-load-path addrinfo:addr addrinfo:canonname addrinfo:fam addrinfo:flags addrinfo:protocol addrinfo:socktype adjust-port-revealed! after-backtrace-hook after-error-hook after-eval-hook after-gc-hook after-print-hook after-read-hook alarm allocate-struct array->list array-cell-set! array-contents array-copy! array-copy-in-order! array-dimensions array-equal? array-fill! array-in-bounds? array-index-map! array-map! array-map-in-order! array-set! array-slice array-slice-for-each array-slice-for-each-in-order array-type-code asinh assert-load-verbosity assoc-remove! assoc-set! assq-remove! assq-set! assv-remove! assv-set! atanh autoload-done! autoload-done-or-in-progress? autoload-in-progress! autoloads-done autoloads-in-progress backtrace basename batch-mode? beautify-user-module! before-backtrace-hook before-error-hook before-eval-hook before-print-hook before-read-hook begin-deprecated bind bind-textdomain-codeset bindtextdomain bit-count bit-count* bit-extract bit-invert! bit-position bit-set*! bitvector bitvector->list bitvector-bit-clear? bitvector-bit-set? bitvector-clear-all-bits! bitvector-clear-bit! bitvector-clear-bits! bitvector-copy bitvector-count bitvector-count-bits bitvector-fill! bitvector-flip-all-bits! bitvector-position bitvector-set-all-bits! bitvector-set! bitvector-set-bits! call-with-blocked-asyncs call-with-deferred-observers call-with-include-port call-with-module-autoload-lock call-with-unblocked-asyncs canonicalize-path centered-quotient centered-remainder centered/ char-general-category char-is-both? char-set-adjoin char-set-adjoin! char-set-any char-set-complement char-set-complement! char-set-copy char-set-count char-set-cursor char-set-cursor-next char-set-delete char-set-delete! char-set-diff+intersection char-set-diff+intersection! char-set-difference char-set-difference! char-set-every char-set-filter char-set-filter! char-set-fold char-set-for-each char-set-hash char-set-intersection char-set-intersection! char-set-map char-set-ref char-set-size char-set-unfold char-set-unfold! char-set-union! char-set-xor char-set-xor! char-set:designated char-set<= char-set= char-titlecase chdir chmod chmodat chown chown-at chroot close-fdes closedir compose connect cons-source convert-assignment copy-file copy-random-state cosh crypt ctermid current-filename current-language current-load-port current-module current-reader current-source-location current-warning-port datum->random-state debug-disable debug-enable debug-options debug-options-interface debug-set! default-duplicate-binding-handler default-duplicate-binding-procedures define! define-library define-macro define-module define-module* define-once define-option-interface define-private define-public define-syntax-parameter defined? defmacro defmacro-public delete delete! delete-file delete-file-at delete1! delv delv! delv1! directory-stream? dirname display-application display-backtrace display-error dup dup->fdes dup->inport dup->outport dup->port dup2 duplicate-handlers duplicate-port dynamic-call dynamic-func dynamic-link dynamic-object? dynamic-pointer dynamic-unlink effective-version end-of-char-set? endgrent endhostent endnetent endprotoent endpwent endservent ensure-batch-mode! environ eval eval-string eval-when exception-accessor exception-args exception-kind exception-predicate exception-type? execl execle execlp exit-hook export export! export-syntax fcntl fdes->inport fdes->outport fdes->ports fdopen file-encoding file-exists? file-is-directory? file-name-separator-string file-name-separator? file-port? file-set-position fileno flock fluid->parameter fluid-bound? fluid-ref* fluid-thread-local? fluid-unset! flush-all-ports frame-address frame-arguments frame-dynamic-link frame-instruction-pointer frame-previous frame-procedure-name frame-return-address frame-source frame-stack-pointer frame? fsync gai-strerror gc gc-disable gc-dump gc-enable gc-run-time gc-stats gensym get-internal-real-time get-internal-run-time get-print-state getaddrinfo getaffinity getcwd getegid getenv geteuid getgid getgr getgrent getgrgid getgrnam getgroups gethost gethostbyaddr gethostbyname gethostent gethostname getitimer getlogin getnet getnetbyaddr getnetbyname getnetent getpass getpeername getpgrp getpid getppid getpriority getproto getprotobyname getprotobynumber getprotoent getpw getpwent getpwnam getpwuid getrlimit getserv getservbyname getservbyport getservent getsid getsockname getsockopt gettext gettimeofday getuid gmtime group:gid group:mem group:name group:passwd has-shown-backtrace-hint? hook->list hook-empty? hook? hostent:addr-list hostent:addrtype hostent:aliases hostent:length hostent:name import in-vicinity include include-ci include-deprecated-features include-library-declarations inet-lnaof inet-makeaddr inet-netof inet-ntop inherit-print-state install-r6rs! install-r7rs! integer-expt integer-length interaction-environment internal-time-units-per-second isatty? keyword-like-symbol->keyword kill kw-arg-ref library link list->array list->bitvector list->char-set! list->symbol list->typed-array list-cdr-ref list-cdr-set! list-index listen load load-compiled load-extension load-from-path load-in-vicinity load-user-init local-define local-define-module local-ref local-ref-module local-remove local-set! localtime log10 lookup-duplicates-handlers lstat macro-binding macro-name macro-transformer macro-type macro? macroexpand macroexpanded? major-version make-array make-autoload-interface make-exception-type make-fresh-user-module make-generalized-vector make-guardian make-hook make-module make-modules-in make-mutable-parameter make-object-property make-procedure-with-setter make-record-type make-socket-address make-soft-port make-stack make-struct-layout make-struct/no-tail make-struct/simple make-symbol make-syntax-transformer make-thread-local-fluid make-typed-array make-unbound-fluid make-undefined-variable make-variable-transformer make-vtable map-in-order memoize-expression memoized-typecode merge merge! micro-version minor-version mkdir mkdirat mkdtemp mknod mkstemp mkstemp! mktime module-add! module-autoload! module-binder module-bound? module-call-observers module-clear! module-constructor module-declarative? module-defer-observers module-define! module-define-submodule! module-defined-hook module-defined? module-duplicates-handlers module-ensure-local-variable! module-export! module-export-all! module-filename module-for-each module-generate-unique-id! module-gensym module-import-interface module-import-obarray module-inlinable-exports module-kind module-local-variable module-locally-bound? module-make-local-var! module-map module-modified module-name module-next-unique-id module-obarray module-obarray-get-handle module-obarray-ref module-obarray-remove! module-obarray-set! module-observe module-observe-weak module-observers module-public-interface module-re-export! module-ref module-ref-submodule module-remove! module-replace! module-replacements module-reverse-lookup module-search module-submodule-binder module-submodules module-symbol-binding module-symbol-interned? module-symbol-local-binding module-symbol-locally-interned? module-transformer module-type module-unobserve module-use! module-use-interfaces! module-uses module-variable module-version module-weak-observers module? modulo-expt move->fdes nested-define! nested-define-module! nested-ref nested-ref-module nested-remove! nested-set! netent:addrtype netent:aliases netent:name netent:net ngettext nice nil? noop object-properties object-property open open-fdes open-fdes-at open-file open-file open-io-file openat opendir parameter-converter parameter-fluid parse-path parse-path-with-ellipsis passwd:dir passwd:gecos passwd:gid passwd:name passwd:passwd passwd:shell passwd:uid pause pipe port->fdes port-for-each port-mode port-revealed port-with-print-state prefab-record-types primitive-_exit primitive-eval primitive-exit primitive-fork primitive-load primitive-load-path primitive-move->fdes primitive-read print-disable print-enable print-exception print-options print-options-interface print-set! procedure procedure-documentation procedure-minimum-arity procedure-properties procedure-property procedure-source procedure-with-setter? process-use-modules protoent:aliases protoent:name protoent:proto provide provided? purify-module! putenv raise random random-state->datum random-state-from-platform random:exp random:hollow-sphere! random:normal random:normal-vector! random:solid-sphere! random:uniform re-export re-export-syntax read-disable read-enable read-eval? read-hash-extend read-hash-procedure read-hash-procedures read-options read-options-interface read-set! read-syntax readdir readlink record-accessor record-constructor record-modifier record-predicate record-type-constructor record-type-descriptor record-type-extensible? record-type-fields record-type-has-parent? record-type-mutable-fields record-type-name record-type-opaque? record-type-parent record-type-properties record-type-uid record-type-vtable record-type? recv! recvfrom! redirect-port release-port-handle reload-module remove-hook! rename-file rename-file-at repl-reader require-extension reset-hook! resolve-interface resolve-module resolve-r6rs-interface restore-signals reverse-list->string rewinddir rmdir round-ash round-quotient round-remainder round/ run-hook save-module-excursion search-path seed->random-state select self-evaluating? send sendfile sendto servent:aliases servent:name servent:port servent:proto set-autoloaded! set-current-dynamic-state set-current-error-port set-current-input-port set-current-module set-current-output-port set-exception-printer! set-module-binder! set-module-declarative?! set-module-duplicates-handlers! set-module-filename! set-module-inlinable-exports! set-module-kind! set-module-name! set-module-next-unique-id! set-module-obarray! set-module-observers! set-module-public-interface! set-module-submodule-binder! set-module-submodules! set-module-transformer! set-module-uses! set-module-version! set-object-properties! set-object-property! set-port-column! set-port-filename! set-port-line! set-port-revealed! set-procedure-minimum-arity! set-procedure-properties! set-procedure-property! set-program-arguments set-source-properties! set-source-property! set-struct-vtable-name! set-symbol-property! set-tm:gmtoff set-tm:hour set-tm:isdst set-tm:mday set-tm:min set-tm:mon set-tm:sec set-tm:wday set-tm:yday set-tm:year set-tm:zone setaffinity setegid setenv seteuid setgid setgr setgrent setgroups sethost sethostent sethostname setitimer setlocale setnet setnetent setpgid setpriority setproto setprotoent setpw setpwent setrlimit setserv setservent setsid setsockopt setter setuid shared-array-increments shared-array-offset shared-array-root shutdown sigaction signal-handlers sinh sleep sloppy-assoc sloppy-assq sloppy-assv sockaddr:addr sockaddr:fam sockaddr:flowinfo sockaddr:path sockaddr:port sockaddr:scopeid socket socketpair sorted? source-properties source-property source-whash spawn stack-id stack-length stack-ref stack? standard-vtable-fields start-stack stat stat:atime stat:atimensec stat:blksize stat:blocks stat:ctime stat:ctimensec stat:dev stat:gid stat:ino stat:mode stat:mtime stat:mtimensec stat:nlink stat:perms stat:rdev stat:size stat:type stat:uid statat status:exit-val status:stop-sig status:term-sig strerror strftime string->char-set! string-any string-any-c-code string-append/shared string-bytes-per-char string-capitalize string-capitalize! string-ci->symbol string-ci< string-ci<= string-ci<> string-ci= string-ci> string-ci>= string-compare string-compare-ci string-concatenate-reverse/shared string-concatenate/shared string-contains string-contains-ci string-count string-delete string-downcase! string-drop string-drop-right string-every string-every-c-code string-filter string-fold string-fold-right string-for-each-index string-hash string-hash-ci string-map! string-normalize-nfc string-normalize-nfd string-normalize-nfkc string-normalize-nfkd string-pad string-pad-right string-prefix-length string-prefix-length-ci string-replace string-reverse! string-skip string-skip-right string-suffix-length string-suffix-length-ci string-tabulate string-take string-take-right string-titlecase string-titlecase! string-tokenize string-unfold string-unfold-right string-upcase! string-utf8-length string-xcopy! string< string<= string<> string= string> string>= strptime struct-layout struct-ref struct-ref/unboxed struct-set! struct-set!/unboxed struct-vtable struct-vtable-name struct-vtable? struct? substring-fill! substring-move! substring/copy substring/read-only supports-source-properties? symbol symbol-append symbol-fref symbol-fset! symbol-hash symbol-interned? symbol-pref symbol-prefix-proc symbol-property symbol-property-remove! symbol-pset! symlink symlinkat sync syntax-parameterize syntax-source system system* system-async-mark system-error-errno system-file-name-convention tanh tcgetpgrp tcsetpgrp textdomain the-root-module the-scm-module thunk? times tm:gmtoff tm:hour tm:isdst tm:mday tm:min tm:mon tm:sec tm:wday tm:yday tm:year tm:zone tmpfile tmpnam tms:clock tms:cstime tms:cutime tms:stime tms:utime transpose-array truncate truncate-file truncate-quotient truncate-remainder truncate/ try-load-module try-module-autoload ttyname typed-array? tzset ucs-range->char-set ucs-range->char-set! umask uname unmemoize-expression unsetenv use-modules use-srfis user-modules-declarative? using-readline? usleep utime utsname:machine utsname:nodename utsname:release utsname:sysname utsname:version variable-bound? variable-unset! vector-move-right! version version-matches? vtable-index-layout vtable-index-printer vtable-offset-user waitpid warn with-continuation-barrier with-ellipsis xsubstring)) (library (guile) (export %default-port-conversion-strategy %default-port-encoding %make-void-port &compound-exception &error &exception &non-continuable * *unspecified* @@ + - ->bool ... / 1+ 1- < <= = => > >= _ AF_INET AF_INET6 SEEK_CUR SEEK_END SEEK_SET abort-to-prompt abs acons acos and and-map and=> angle append append! apply array? array-cell-ref array-for-each array-length array-rank array-ref array-shape array-type ash asin assoc assoc-ref assq assq-ref assv assv-ref atan begin bitvector-length bitvector-ref bitvector-set-bit! bitvector? boolean? bound-identifier=? caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr call-with-current-continuation call-with-input-file call-with-input-string call-with-output-file call-with-output-string call-with-port call-with-prompt call-with-values call/cc car case case-lambda case-lambda* catch cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling ceiling-quotient ceiling-remainder ceiling/ char->integer char-alphabetic? char-ci<=? char-ci=? char-ci>? char-downcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? char<=? char=? char>? char? char-set char-set-union char-set->list char-set->string char-set? char-set-contains? char-set:ascii char-set:blank char-set:digit char-set:empty char-set:full char-set:graphic char-set:hex-digit char-set:iso-control char-set:letter char-set:letter+digit char-set:lower-case char-set:printing char-set:punctuation char-set:symbol char-set:title-case char-set:upper-case char-set:whitespace close close-input-port close-output-port close-port command-line complex? cond cond-expand cond-expand-provide cons cons* const cos current-dynamic-state current-error-port current-input-port current-output-port current-time datum->syntax default-prompt-tag define define* define-inlinable define-syntax define-syntax-rule define-values delay delq delq! delq1! denominator display do doubly-weak-hash-table? drain-input dynamic-state? dynamic-wind else eof-object? eq? equal? eqv? error euclidean-quotient euclidean-remainder euclidean/ even? (rename (inexact exact->inexact)) exact-integer-sqrt exact-integer? exact? exception? exit exp expt false-if-exception file-position filter filter! finite? floor floor-quotient floor-remainder floor/ fluid-ref fluid-set! fluid? for-each force force-output format free-identifier=? ftell gcd generate-temporaries get-output-string hash hash-clear! hash-count hash-create-handle! hash-fold hash-for-each hash-for-each-handle hash-get-handle hash-map->list hash-ref hash-remove! hash-set! hash-table? hashq hashq-create-handle! hashq-get-handle hashq-ref hashq-remove! hashq-set! hashv hashv-create-handle! hashv-get-handle hashv-ref hashv-remove! hashv-set! hashx-create-handle! hashx-get-handle hashx-ref hashx-remove! hashx-set! identifier-syntax identifier? identity if imag-part include-from-path (rename (exact inexact->exact)) inet-pton inexact? inf (rename (infinite? inf?)) input-port? integer->char integer? iota issue-deprecation-warning keyword->symbol keyword? lambda lambda* last-pair lcm length let let* let-syntax letrec letrec* letrec-syntax list list->char-set list->string list->vector list-copy list-head list-ref list-set! list-tail list? log logand logbit? logcount logior lognot logtest logxor magnitude make-bitvector make-doubly-weak-hash-table make-exception make-exception-from-throw make-fluid make-hash-table make-list make-parameter make-polar make-promise make-prompt-tag make-rectangular make-regexp make-shared-array make-string (rename (make-box make-variable)) make-vector make-weak-key-hash-table make-weak-value-hash-table map max member memq memv min module-set! modulo most-negative-fixnum most-positive-fixnum nan nan? negate negative? newline not null? number->string number? numerator object->string object-address odd? open-input-file open-input-string open-output-file open-output-string or or-map output-port? pair? parameter? parameterize peek peek-char pk port-closed? port-column port-conversion-strategy port-encoding port-filename port-line port? positive? procedure? procedure-name program-arguments promise? quasiquote quasisyntax quit quote quote-syntax quotient raise-exception rational? rationalize read read-char real-part real? record-type-parents record? regexp-exec regexp/basic regexp/extended regexp/icase regexp/newline regexp/notbol regexp/noteol regexp? remainder restricted-vector-sort! reverse reverse! round seek scm-error set! set-car! set-cdr! set-port-conversion-strategy! set-port-encoding! setvbuf simple-exceptions simple-format sin sort sort! sort-list sort-list! sqrt stable-sort stable-sort! string string->char-set string->list string->number string->symbol string-append string-capitalize string-ci<=? string-ci=? string-ci>? string-concatenate string-concatenate-reverse string-copy string-copy! string-downcase string-fill! string-for-each string-index string-index-right string-join string-length string-map string-null? string-prefix-ci? string-prefix? string-pad string-ref string-reverse string-rindex string-trim string-trim-both string-trim-right string-set! string-split string-suffix-ci? string-suffix? string-upcase string<=? string=? string>? string? substring substring/shared symbol->keyword symbol->string symbol? syntax syntax->datum syntax-case syntax-error syntax-rules syntax-violation tan the-eof-object throw unless unquote unquote-splicing unread-char unread-string unspecified? unsyntax unsyntax-splicing values (rename (box-ref variable-ref)) (rename (box-set! variable-set!)) (rename (box? variable?)) vector vector->list vector-copy vector-copy! vector-fill! vector-length vector-move-left! vector-ref vector-set! vector? weak-key-hash-table? weak-value-hash-table? when while with-dynamic-state with-error-to-file with-error-to-port with-error-to-string with-exception-handler with-fluid* with-fluids with-fluids* with-input-from-file with-input-from-port with-input-from-string with-output-to-file with-output-to-port with-output-to-string with-syntax with-throw-handler write write-char zero? Ī») (import (hoot assoc) (hoot bitvectors) (hoot bitwise) (hoot boxes) (hoot bytevectors) (hoot char) (hoot cond-expand) (hoot control) (hoot dynamic-states) (hoot dynamic-wind) (hoot eq) (hoot equal) (hoot error-handling) (hoot errors) (hoot exceptions) (hoot features) (hoot fluids) (hoot hashtables) (hoot keywords) (except (hoot lists) sort) (prefix (only (hoot lists) sort) list:) (hoot not) (hoot numbers) (hoot pairs) (hoot parameters) (hoot ports) (hoot apply) (hoot procedures) (only (hoot read) read string->number) (hoot records) (hoot regexps) (except (hoot strings) substring) (prefix (only (hoot strings) substring) hoot:) (hoot syntax) (hoot syntax-objects) (hoot symbols) (hoot values) (hoot vectors) (hoot write) (ice-9 match) (only (scheme base) boolean?) (only (scheme char) char-ci=? char-ci>? string-ci=? string-ci>?) (only (scheme file) open-input-file open-output-file call-with-input-file call-with-output-file with-input-from-file with-output-to-file) (scheme lazy) (scheme process-context) (scheme time) (srfi srfi-14)) ;; FIXME: Guile's SRFI modules use this but it relies on the module ;; API which we don't implement. (define-syntax-rule (cond-expand-provide module feature) (values)) ;; FIXME: @@ is unsupported, but there are modules in Guile that we ;; want to be able to import and expand even if they are partially ;; unusable at runtime. So, we don't throw an error at expansion ;; time but rather runtime if the procedure is ever called. We need ;; to fix modules in Guile so that they don't use @@. (define-syntax-rule (@@ module name) (lambda args (raise (make-unimplemented-error '@@)))) ;; FIXME: No-op for now to get modules like (ice-9 format) working. (define-syntax-rule (module-set! module name value) (values)) (define-syntax define-inlinable (lambda (stx) (syntax-case stx () ((_ (name formals ...) body0 body ...) (identifier? #'name) (let ((proc-name (string->symbol (string-append "% " (symbol->string (syntax->datum #'name)) "-procedure")))) (with-syntax ((proc-name (datum->syntax #'name proc-name)) ((args ...) (generate-temporaries #'(formals ...)))) #'(begin (define (proc-name formals ...) body0 body ...) (define-syntax name (lambda (stx) (syntax-case stx () ((_ args ...) #'((lambda (formals ...) body0 body ...) args ...)) ((_ bad-arg (... ...)) (syntax-violation 'name "wrong number of arguments" stx)) (_ (identifier? stx) #'proc-name))))))))))) ;; FIXME: Doesn't support break/continue due to compiler bug. ;; ;; See https://gitlab.com/spritely/guile-hoot/-/issues/316 (define-syntax-rule (while cond body ...) (let lp () (and cond (begin body ... (lp))))) (define (identity x) x) (define (const x) (lambda args x)) ;; TODO: Implement arrays. (define (array? obj) #f) (define (make-shared-array array proc . dims) (raise (make-unimplemented-error 'make-shared-array))) (define (array-type array) (raise (make-unimplemented-error 'array-type))) (define (array-length array) (raise (make-unimplemented-error 'array-length))) (define (array-rank array) (raise (make-unimplemented-error 'array-rank))) (define (array-shape array) (raise (make-unimplemented-error 'array-shape))) (define (array-ref array . idx) (raise (make-unimplemented-error 'array-ref))) (define (array-cell-ref array . idx) (raise (make-unimplemented-error 'array-cell-ref))) (define (array-for-each proc . arrays) (raise (make-unimplemented-error 'array-for-each))) (define (%make-void-port mode) (define (mode-prefix-match? test) (call-with-input-string mode (lambda (p) (let lp ((c (read-char p))) (cond ((eof-object? c) #f) ((or (test c) (char-ci=? c #\+)) #t) (else (lp (read-char p)))))))) (define %read (and (mode-prefix-match? (lambda (c) (char-ci=? c #\r))) (lambda (bv start count) (eof-object)))) (define %write (and (mode-prefix-match? (lambda (c) (or (char-ci=? c #\w) (char-ci=? c #\a)))) (lambda (bv start count) count))) (make-port #:read %read #:write %write #:repr "void")) (define-syntax *unspecified* (identifier-syntax (if #f #f))) (define (->bool x) (if x #t #f)) (define (and-map f l) (match l (() #t) ((x . l) (and (f x) (and-map f l))))) (define (or-map f l) (match l (() #f) ((x . l) (or (f x) (or-map f l))))) (define (filter pred l) (match l (() '()) ((head . tail) (if (pred head) (cons head (filter pred tail)) (filter pred tail))))) (define* (iota count #:optional (start 0) (step 1)) "Return a list of length @var{count} containing numbers starting with @var{start} and incrementing by @var{step}. @var{start} defaults to 0 and @var{step} to 1." (assert (>= count 0) 'iota) (if (zero? count) '() (cons start (iota (1- count) (+ start step) step)))) (define (and=> x f) (and x (f x))) (define (list-head lst k) (if (zero? k) '() (cons (car lst) (list-head (cdr lst) (1- k))))) ;; Guile's manual says that append! and filter! are not required to ;; modify the list, so let's not! (define append! append) (define filter! filter) (define* (reverse! lst #:optional (newtail '())) (append (reverse lst) newtail)) (define (delq item lst) (match lst (() '()) ((x . rest) (if (eq? item x) (delq item rest) (cons x (delq item rest)))))) (define (delq! item lst) (match lst (() '()) ((x . rest) (if (eq? item x) (delq! item rest) (let ((rest* (delq! item rest))) (set-cdr! lst rest*) lst))))) (define (delq1! item lst) (match lst (() '()) ((x . rest) (if (eq? item x) rest (let ((rest* (delq1! item rest))) (set-cdr! lst rest*) lst))))) (define sort-list list:sort) (define sort-list! sort-list) (define (restricted-vector-sort! v less? start end) (vector-sort! v less? start end)) (define (sort! items <) (match items (() '()) ((? pair?) (sort-list items <)) ((? vector?) (restricted-vector-sort! items < 0 (vector-length items)) items))) (define (sort items <) (match items (() '()) ((? pair?) (sort-list items <)) ((? vector?) (let ((v (vector-copy items))) (restricted-vector-sort! v < 0 (vector-length v)) v)))) ;; FIXME: vector-sort! is not stable. (define stable-sort sort) (define stable-sort! sort!) (define (call-with-input-string str proc) (proc (open-input-string str))) (define (call-with-output-string proc) (let ((port (open-output-string))) (proc port) (get-output-string port))) (define (with-input-from-string str thunk) (call-with-input-string str (lambda (port) (with-input-from-port port thunk)))) (define (with-output-to-string thunk) (call-with-output-string (lambda (port) (with-output-to-port port thunk)))) (define (with-input-from-port port thunk) (parameterize ((current-input-port port)) (thunk))) (define (with-output-to-port port thunk) (parameterize ((current-output-port port)) (thunk))) (define (with-error-to-port port thunk) (parameterize ((current-error-port port)) (thunk))) (define (with-error-to-file filename thunk) (call-with-port (open-output-file filename) (lambda (port) (with-error-to-port port thunk)))) (define (with-error-to-string thunk) (call-with-output-string (lambda (port) (with-error-to-port port thunk)))) (define (current-time) (exact (truncate (current-second)))) (define (ftell port) (seek port 0 'cur)) (define file-position ftell) (define* (drain-input #:optional (port (current-input-port))) (flush-input-port port)) (define* (force-output #:optional (port (current-output-port))) (flush-output-port port)) (define (simple-format port template . args) (define (do-format port) (call-with-input-string template (lambda (in) (let lp ((args args)) (match (read-char in) ((? eof-object?) (match args (() (force-output port)) (_ (error "leftover format args" template args)))) (#\~ (match (read-char in) ((or #\a #\A) (match args ((x . args) (display x port) (lp args)) (_ (error "not enough format args" template)))) ((or #\s #\S) (match args ((x . args) (write x port) (lp args)) (_ (error "not enough format args" template)))) (#\~ (write-char #\~ port) (lp args)) (#\% (newline port) (lp args)) (ch (error "unexpected format directive" template ch)))) (ch (write-char ch port) (lp args)))) (if #f #f)))) (match port (#t (do-format (current-output-port))) (#f (call-with-output-string do-format)) ((? output-port?) (do-format port)) (_ (error "invalid format destination" port)))) (define format simple-format) (define (inf) +inf.0) (define (nan) +nan.0) (define (negate x) (- x)) (define* (object->string obj #:optional (print write)) (call-with-output-string (lambda (port) (print obj port)))) ;; Object addresses are not visible in Wasm. (define (object-address obj) 0) (define (string-null? str) (string=? str "")) (define (string-concatenate strs) (apply string-append strs)) (define (string-split str char-pred) (let ((char-pred (match char-pred ((? char? a) (lambda (b) (char=? a b))) ((? char-set? cs) (lambda (c) (char-set-contains? cs c))) ((? procedure?) char-pred)))) (call-with-input-string str (lambda (port) (define (read-to-delimiter) (list->string (let lp () (match (peek-char port) ((? eof-object?) '()) ((? char-pred) '()) (c (cons (read-char port) (lp))))))) (let lp () (let ((substr (read-to-delimiter))) (match (read-char port) ((? eof-object?) (list substr)) (_ (cons substr (lp)))))))))) (define* (string-join strs #:optional (delimiter " ") (grammar 'infix)) (define (prefix-join strs) (match strs (() '()) ((str . rest) (cons* delimiter str (prefix-join rest))))) (string-concatenate (match grammar ('infix (match strs (() '()) ((first . rest) (cons first (prefix-join rest))))) ('strict-infix (match strs (() (error "strict-infix join with empty list")) ((first . rest) (cons first (prefix-join rest))))) ('prefix (prefix-join strs)) ('suffix (let lp ((strs strs)) (match strs (() '()) ((str . rest) (cons* str delimiter (lp rest))))))))) (define* (substring str start #:optional (end (string-length str))) (hoot:substring str start end)) (define substring/shared substring) (define* (string-concatenate-reverse strs #:optional final end) (string-concatenate (reverse (if final (cons (if end (substring final 0 end) final) strs) strs)))) (define* (string-pad str len #:optional (char #\space) (start 0) (end (string-length str))) (let ((k (- len (- end start)))) (cond ((zero? k) (substring str start end)) ((< k 0) (substring str (+ start (* k -1)) end)) (else (string-append (make-string k char) (substring str start end)))))) (define* (string-index s char-pred #:optional (start 0) (end (string-length s))) (let ((char-pred (match char-pred ((? char?) (lambda (c) (char=? c char-pred))) ((? char-set? cs) (lambda (c) (char-set-contains? cs c))) ((? procedure?) char-pred)))) (let lp ((i 0) (sl (string->list (substring s start end)))) (match sl (() #f) (((? char-pred) . rest) (+ start i)) ((c . rest) (lp (1+ i) rest)))))) (define* (string-rindex s char-pred #:optional (start 0) (end (string-length s))) (let ((i (string-index (string-reverse (substring s start end)) char-pred))) (and i (- end i 1)))) (define string-index-right string-rindex) (define (%string-prefix? s1 s2 start1 end1 start2 end2 string-equal?) (let ((k (- end1 start1))) (and (<= k (- end2 start2)) (string-equal? (substring s1 start1 end1) (substring s2 start2 (+ start2 k)))))) (define* (string-prefix? s1 s2 #:optional (start1 0) (end1 (string-length s1)) (start2 0) (end2 (string-length s2))) (%string-prefix? s1 s2 start1 end1 start2 end2 string=?)) (define* (string-prefix-ci? s1 s2 #:optional (start1 0) (end1 (string-length s1)) (start2 0) (end2 (string-length s2))) (%string-prefix? s1 s2 start1 end1 start2 end2 string-ci=?)) (define (%string-suffix? s1 s2 start1 end1 start2 end2 string-equal?) (let ((k (- end1 start1))) (and (<= k (- end2 start2)) (string-equal? (substring s1 start1 end1) (substring s2 (- end2 k) end2))))) (define* (string-suffix? s1 s2 #:optional (start1 0) (end1 (string-length s1)) (start2 0) (end2 (string-length s2))) (%string-suffix? s1 s2 start1 end1 start2 end2 string=?)) (define* (string-suffix-ci? s1 s2 #:optional (start1 0) (end1 (string-length s1)) (start2 0) (end2 (string-length s2))) (%string-suffix? s1 s2 start1 end1 start2 end2 string-ci=?)) (define* (string-reverse str #:optional (start 0) (end (string-length str))) (let ((pre (substring str 0 start)) (post (substring str end (string-length str)))) (string-append pre (list->string (reverse (string->list (substring str start end)))) post))) (define (%string-trim sl char-pred) (let ((char-pred (match char-pred ((? char?) (lambda (c) (char=? c char-pred))) ((? char-set? cs) (lambda (c) (char-set-contains? cs c))) ((? procedure?) char-pred)))) (let lp ((sl sl)) (match sl (() '()) (((? char-pred c) . rest) (lp rest)) (_ sl))))) (define* (string-trim s #:optional (char-pred char-set:whitespace) (start 0) (end (string-length s))) (list->string (%string-trim (string->list (substring s start end)) char-pred))) (define* (string-trim-right s #:optional (char-pred char-set:whitespace) (start 0) (end (string-length s))) (list->string (reverse (%string-trim (reverse (string->list (substring s start end))) char-pred)))) (define* (string-trim-both s #:optional (char-pred char-set:whitespace) (start 0) (end (string-length s))) (string-trim-right (string-trim s char-pred start end) char-pred)) (define (string-capitalize str) (raise (make-unimplemented-error 'string-capitalize))) (define (last-pair l) (match l ((_ . (and l (_ . _))) (last-pair l)) ((_ . _) l) (_ (error "not a pair" l)))) (define (peek . stuff) (newline) (display ";;; ") (write stuff) (newline) (flush-output-port (current-output-port)) (car (last-pair stuff))) (define pk peek) (define %default-port-conversion-strategy (make-fluid 'substitute)) (define %default-port-encoding (make-fluid "UTF-8")) (define close close-port) (define (port-closed? port) (not (port-open? port))) (define SEEK_CUR 'cur) (define SEEK_SET 'start) (define SEEK_END 'end) (define* (unread-char char #:optional (port (current-input-port))) (raise (make-unimplemented-error 'unread-char))) (define* (unread-string str port) (raise (make-unimplemented-error 'unread-string))) (define* (setvbuf port mode #:optional size) (raise (make-unimplemented-error 'setvbuf))) (define (program-arguments) (command-line)) (define quit exit) (define the-eof-object (eof-object)) (define (unspecified? x) (eq? x *unspecified*)) (define-syntax-rule (Ī» formals body ...) (lambda formals body ...)) (define* (catch key thunk handler #:optional pre-unwind-handler) (raise (make-unimplemented-error 'catch))) ;; TODO: Should we handle Guile's legacy key + args exception ;; system? (define (with-throw-handler key thunk handler) (unless (eq? key #t) (raise (make-unimplemented-error 'with-throw-handler))) (with-exception-handler (lambda (exn) (apply handler #t '()) (raise-exception exn)) thunk)) ;; TODO: Implement Guile's conversions based on key. (define (make-exception-from-throw key args) (make-exception-with-irritants args)) (define (throw key . args) (raise-exception (make-exception-from-throw key args))) (define (scm-error key subr message args data) (raise (make-exception (make-exception-from-throw key args) (make-exception-with-message (apply format #f message args)) (make-exception-with-origin subr)))) (define-syntax-rule (false-if-exception expr) (with-exception-handler (lambda (exn) #f) (lambda () expr) #:unwind? #t)) (define issue-deprecation-warning (let ((past-messages (make-hashtable))) (lambda msgs (let ((msgs-str (string-concatenate msgs))) (unless (hashtable-contains? past-messages msgs-str) (hashtable-set! past-messages msgs-str #t) (display msgs-str (current-error-port)) (newline (current-error-port))))))) ;; Hash table API compatibility shim: ;; ;; Guile's legacy hash table API is not so great. It allows for ;; mixing different hash functions in the same table, which is why ;; there are *four* variants for ref/set!/remove! procedures. On ;; top of that, the API is also polymorphic. Those same procedures ;; are used on "normal", weak key, weak value, and doubly weak ;; tables. ;; ;; We made a better interface in (hoot hashtables) that resembles ;; the R6RS API and is monomorphic. However, in the interest of ;; maximizing the amount of existing Guile code that can be compiled ;; as-is with Hoot, we have provided this compatibility shim. ;; ;; Hoot does *not* provide full compatibility, just partial ;; compatibility for common use-cases. Code that is mixing hash ;; functions in the same table or using ;; hash-get-handle/hash-create-handle! is not supported. Also, ;; because hashx-* procedures use assoc and friends, which is ;; incompatible with how (hoot hashtables) does equality testing, we ;; force equal? as the equivalence function. (define-record-type (%make-hash-table type table) hash-table? (type hash-table-type) ; normal, weak-key, weak-value, doubly-weak (table hash-table-table set-hash-table-table!)) ; lazily initialized (define* (make-hash-table #:optional size) "Return a new hash table. @var{size} is ignored." (%make-hash-table 'normal #f)) (define* (make-weak-key-hash-table #:optional size) "Return a new weak key hash table. @var{size} is ignored." (%make-hash-table 'weak-key #f)) (define* (make-weak-value-hash-table #:optional size) "Return a new weak value hash table. @var{size} is ignored." (%make-hash-table 'weak-value #f)) (define* (make-doubly-weak-hash-table #:optional size) "Return a new doubly weak hash table. @var{size} is ignored." (%make-hash-table 'doubly-weak #f)) (define (weak-key-hash-table? obj) "Return @code{#t} if @var{obj} is a weak key hash table." (and (hash-table? obj) (eq? (hash-table-type obj) 'weak-key))) (define (weak-value-hash-table? obj) "Return @code{#t} if @var{obj} is a weak value hash table." (and (hash-table? obj) (eq? (hash-table-type obj) 'weak-value))) (define (doubly-weak-hash-table? obj) "Return @code{#t} if @var{obj} is a doubly weak hash table." (and (hash-table? obj) (eq? (hash-table-type obj) 'doubly-weak))) ;; Should these assert that the hash and equiv functions are what we ;; expect? Currently, mixing hash functions on the same table will ;; just silently use the hash function of the first ref/set!/remove! ;; call. (define (maybe-init-equal-hashtable table) (unless (hash-table-table table) (set-hash-table-table! table (match (hash-table-type table) ('normal (make-hashtable)) ('weak-key (make-weak-key-hashtable)) ('weak-value (make-weak-value-hashtable)) ('doubly-weak (make-doubly-weak-hashtable)))))) (define (maybe-init-eq-hashtable table) (unless (hash-table-table table) (set-hash-table-table! table (match (hash-table-type table) ('normal (make-eq-hashtable)) ('weak-key (make-eq-weak-key-hashtable)) ('weak-value (make-eq-weak-value-hashtable)) ('doubly-weak (make-eq-doubly-weak-hashtable)))))) (define (maybe-init-eqv-hashtable table) (unless (hash-table-table table) (set-hash-table-table! table (match (hash-table-type table) ('normal (make-eqv-hashtable)) ('weak-key (make-eqv-weak-key-hashtable)) ('weak-value (make-eqv-weak-value-hashtable)) ('doubly-weak (make-eqv-doubly-weak-hashtable)))))) (define (maybe-init-custom-hashtable table hash equiv) (unless (hash-table-table table) (set-hash-table-table! table (match (hash-table-type table) ('normal (make-hashtable hash equiv)) ('weak-key (make-weak-key-hashtable hash equiv)) ('weak-value (make-weak-value-hashtable hash equiv)) ('doubly-weak (make-doubly-weak-hashtable hash equiv)))))) (define (%hash-ref table key default) (let ((table* (hash-table-table table))) (match (hash-table-type table) ('normal (hashtable-ref table* key default)) ('weak-key (weak-key-hashtable-ref table* key default)) ('weak-value (weak-value-hashtable-ref table* key default)) ('doubly-weak (doubly-weak-hashtable-ref table* key default))))) (define* (hash-ref table key #:optional default) "Look up @var{key} in the hash table @var{table}, and return the value associated with it. If @var{key} is not found, return @var{default} (if specified) or @code{#f}. Uses @code{equal?} for equality testing." (maybe-init-equal-hashtable table) (%hash-ref table key default)) (define* (hashq-ref table key #:optional default) "Look up @var{key} in the hash table @var{table}, and return the value associated with it. If @var{key} is not found, return @var{default} (if specified) or @code{#f}. Uses @code{eq?} for equality testing." (maybe-init-eq-hashtable table) (%hash-ref table key default)) (define* (hashv-ref table key #:optional default) "Look up @var{key} in the hash table @var{table}, and return the value associated with it. If @var{key} is not found, return @var{default} (if specified) or @code{#f}. Uses @code{eqv?} for equality testing." (maybe-init-eqv-hashtable table) (%hash-ref table key default)) (define* (hashx-ref hash assoc table key #:optional default) "Look up @var{key} in the hash table @var{table}, and return the value associated with it. If @var{key} is not found, return @var{default} (if specified) or @code{#f}. Uses @var{hash} as the hash function. @var{assoc} is ignored and @code{equal?} is used for equality testing." (maybe-init-custom-hashtable table hash equal?) (%hash-ref table key default)) (define (%hash-set! table key val) (let ((table* (hash-table-table table))) (match (hash-table-type table) ('normal (hashtable-set! table* key val)) ('weak-key (weak-key-hashtable-set! table* key val)) ('weak-value (weak-value-hashtable-set! table* key val)) ('doubly-weak (doubly-weak-hashtable-set! table* key val))) (if #f #f))) (define (hash-set! table key val) "Find the entry in @var{table} associated with @var{key} and store @var{val} there. Uses @code{equal?} for equality testing." (maybe-init-equal-hashtable table) (%hash-set! table key val)) (define (hashq-set! table key val) "Find the entry in @var{table} associated with @var{key} and store @var{val} there. Uses @code{eq?} for equality testing." (maybe-init-eq-hashtable table) (%hash-set! table key val)) (define (hashv-set! table key val) "Find the entry in @var{table} associated with @var{key} and store @var{val} there. Uses @code{eqv?} for equality testing." (maybe-init-eqv-hashtable table) (%hash-set! table key val)) (define (hashx-set! hash assoc table key val) "Find the entry in @var{table} associated with @var{key} and store @var{val} there. Uses @var{hash} as the hash function. @var{assoc} is ignored and @code{equal?} is used for equality testing." (maybe-init-custom-hashtable table hash equal?) (%hash-set! table key val)) (define (%hash-remove! table key) (let ((table* (hash-table-table table))) (match (hash-table-type table) ('normal (hashtable-delete! table* key)) ('weak-key (weak-key-hashtable-delete! table* key)) ('weak-value (weak-value-hashtable-delete! table* key)) ('doubly-weak (doubly-weak-hashtable-delete! table* key))) (if #f #f))) (define (hash-remove! table key) "Remove @var{key} from @var{table}. Uses @code{equal?} for equality testing." (maybe-init-equal-hashtable table) (%hash-remove! table key)) (define (hashq-remove! table key) "Remove @var{key} from @var{table}. Uses @code{eq?} for equality testing." (maybe-init-eq-hashtable table) (%hash-remove! table key)) (define (hashv-remove! table key) "Remove @var{key} from @var{table}. Uses @code{eqv?} for equality testing." (maybe-init-eqv-hashtable table) (%hash-remove! table key)) (define (hashx-remove! hash assoc table key) "Remove @var{key} from @var{table}. Uses @var{hash} as the hash function. @var{assoc} is ignored and @code{equal?} is used for equality testing." (maybe-init-custom-hashtable table hash equal?) (%hash-remove! table key)) (define (hash-get-handle table key) (raise (make-unimplemented-error 'hash-get-handle))) (define (hashq-get-handle table key) (raise (make-unimplemented-error 'hashq-get-handle))) (define (hashv-get-handle table key) (raise (make-unimplemented-error 'hashv-get-handle))) (define (hashx-get-handle hash assoc table key) (raise (make-unimplemented-error 'hashx-get-handle))) (define (hash-create-handle! table key init) (raise (make-unimplemented-error 'hash-create-handle!))) (define (hashq-create-handle! table key init) (raise (make-unimplemented-error 'hashq-create-handle!))) (define (hashv-create-handle! table key init) (raise (make-unimplemented-error 'hashv-create-handle!))) (define (hashx-create-handle! hash assoc table key init) (raise (make-unimplemented-error 'hashx-create-handle!))) (define (hash-clear! table) "Remove all items from @var{table}." (match (hash-table-table table) (#f (values)) (table* (match (hash-table-type table) ('normal (hashtable-clear! table*)) ('weak-key (weak-key-hashtable-clear! table*)) ('weak-value (weak-value-hashtable-clear! table*)) ('doubly-weak (doubly-weak-hashtable-clear! table*))))) (if #f #f)) (define (hash-fold proc init table) "Accumulate a result by applying @var{proc} with each key/value association in @var{table} and the result of the previous @var{proc} call. Each call is of the form @code{(proc key value prev)}. For the first call, @code{prev} is the initial value @var{init}." (match (hash-table-table table) (#f init) (table* (match (hash-table-type table) ('normal (hashtable-fold proc init table*)) ('weak-key (weak-key-hashtable-fold proc init table*)) ('weak-value (weak-value-hashtable-fold proc init table*)) ('doubly-weak (doubly-weak-hashtable-fold proc init table*)))))) (define (hash-map->list proc table) "Return an association list of key/value mappings in @var{table}." (hash-fold (lambda (key value result) (cons (proc key value) result)) '() table)) (define (hash-count pred table) "Return the number of elements in @var{table} that satisfy @code{(pred key value)}." (hash-fold (lambda (key val count) (if (pred key val) (1+ count) count)) 0 table)) (define (hash-for-each proc table) "Apply @var{proc} to each key/value association in @var{table}. Each call is of the form @code{(proc key value)}." (match (hash-table-table table) (#f (values)) (table* (match (hash-table-type table) ('normal (hashtable-for-each proc table*)) ('weak-key (weak-key-hashtable-for-each proc table*)) ('weak-value (weak-value-hashtable-for-each proc table*)) ('doubly-weak (doubly-weak-hashtable-for-each proc table*)))))) (define (hash-for-each-handle proc table) (raise (make-unimplemented-error 'hash-for-each-handle))) ;; Regular expressions (define regexp/basic 'basic) (define regexp/extended 'extended) (define regexp/icase 'case-insensitive) (define regexp/newline 'multiline) (define regexp/notbol 'notbol) (define regexp/noteol 'noteol) ;; Sockets (define AF_INET 'ipv4) (define AF_INET6 'ipv6) (define (inet-pton family address) (define (bad-address) (error "bad address" family address)) (define (check-u8 x) (unless (and x (<= 0 x 255)) (bad-address)) x) (define (check-number x) (unless (number? x) (bad-address)) x) (define (read-decimal port) (check-u8 (string->number (list->string (let lp () (match (peek-char port) ((and char (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) (cons (read-char port) (lp))) (_ '()))))))) (define (hex-digit? char) (match char ((or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\f #\A #\B #\C #\D #\E #\F) #t) (_ #f))) (define (read-hexadecimal port) (check-number (string->number (list->string (let lp ((k 0)) (match (peek-char port) ((? hex-digit?) (if (= k 4) (bad-address) (cons (read-char port) (lp (1+ k))))) (_ '())))) 16))) (define (read-dot port) (match (read-char port) (#\. (values)) (_ (bad-address)))) (define (read-colon port) (match (read-char port) (#\: (values)) (_ (bad-address)))) (define (read-decimal-and-dot port) (let ((n (read-decimal port))) (read-dot port) n)) (define (read-hexadecimal-and-colon port) (let ((n (read-hexadecimal port))) (read-colon port) n)) (define (read-ipv6-groups port) (define (iter) (match (peek-char port) ((? eof-object?) '()) ((? hex-digit?) (let ((x (read-hexadecimal port))) (match (read-char port) ((? eof-object?) (list x)) (#\: (cons x (iter)))))) (#\: (read-char port) '()))) (match (peek-char port) ((? eof-object?) '()) ((? hex-digit?) (iter)) (#\: (read-char port) (match (read-char port) (#\: '()) (_ (bad-address)))))) (match family ('ipv4 (call-with-input-string address (lambda (port) (let ((a (read-decimal-and-dot port)) (b (read-decimal-and-dot port)) (c (read-decimal-and-dot port)) (d (read-decimal port))) (if (eof-object? (peek-char port)) (logior (ash a 24) (ash b 16) (ash c 8) d) (bad-address)))))) ;; TODO: IPv6 addresses with embedded IPv4 address. ('ipv6 (call-with-input-string address (lambda (port) (let* ((pre (read-ipv6-groups port)) (post (read-ipv6-groups port)) (pad (- 8 (+ (length pre) (length post))))) (if (> pad 0) (match (append pre (make-list pad 0) post) ((a b c d e f g h) (logior (ash a 112) (ash b 96) (ash c 80) (ash d 64) (ash e 48) (ash f 32) (ash g 16) h)) (_ (bad-address))) (bad-address))))))))) guile-hoot-0.7.0/lib/hoot/000077500000000000000000000000001507574675700153405ustar00rootroot00000000000000guile-hoot-0.7.0/lib/hoot/apply.scm000066400000000000000000000013471507574675700171760ustar00rootroot00000000000000;;; Apply ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; apply ;;; ;;; Code: (library (hoot apply) (export apply) (import (only (hoot primitives) apply))) guile-hoot-0.7.0/lib/hoot/assoc.scm000066400000000000000000000033411507574675700171550ustar00rootroot00000000000000;;; assoc/member ;;; Copyright (C) 2023, 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; assoc, member, and friends. ;;; ;;; Code: (library (hoot assoc) (export assq assv assoc assq-ref assv-ref assoc-ref memq memv member) (import (hoot eq) (hoot equal) (hoot lists) (hoot not) (hoot pairs) (hoot syntax)) (define-syntax-rule (define-member+assoc member assoc assoc-ref compare optarg ...) (begin (define* (member v l optarg ...) (let lp ((l l)) (cond ((null? l) #f) ((compare v (car l)) l) (else (lp (cdr l)))))) (define* (assoc v l optarg ...) (let lp ((l l)) (and (not (null? l)) (let ((head (car l))) (if (compare v (car head)) head (lp (cdr l))))))) (define (assoc-ref l k) (cond ((assoc k l) => cdr) (else #f))))) (define-member+assoc memq assq assq-ref eq?) (define-member+assoc memv assv assv-ref eqv?) (define-member+assoc member assoc assoc-ref compare #:optional (compare equal?))) guile-hoot-0.7.0/lib/hoot/atomics.scm000066400000000000000000000024721507574675700175100ustar00rootroot00000000000000;;; Atomic boxes ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Atomic boxes. ;;; ;;; Code: (library (hoot atomics) (export make-atomic-box atomic-box-ref atomic-box-set! atomic-box-swap! atomic-box-compare-and-swap!) (import (only (hoot primitives) %make-atomic-box %atomic-box-ref %atomic-box-set! %atomic-box-swap! %atomic-box-compare-and-swap!) (hoot syntax)) (define (make-atomic-box x) (%make-atomic-box x)) (define (atomic-box-ref x) (%atomic-box-ref x)) (define (atomic-box-set! x y) (%atomic-box-set! x y)) (define (atomic-box-swap! x y) (%atomic-box-swap! x y)) (define (atomic-box-compare-and-swap! x y z) (%atomic-box-compare-and-swap! x y z))) guile-hoot-0.7.0/lib/hoot/bitvectors.scm000066400000000000000000000101251507574675700202270ustar00rootroot00000000000000;;; Bitvectors ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Bitvectors. ;;; ;;; Code: (library (hoot bitvectors) (export bitvector? make-bitvector bitvector-length bitvector-ref bitvector-set-bit!) (import (rename (only (hoot primitives) %<= %< %- %exact-integer? %bitvector?) (%<= <=) (%< <) (%- -) (%exact-integer? exact-integer?)) (hoot bitwise) (hoot errors) (hoot inline-wasm) (hoot match) (hoot syntax)) (define (1- x) (- x 1)) (define (bitvector? x) (%bitvector? x)) (define* (make-bitvector len #:optional (fill #f)) (check-size len (1- (ash 1 29)) 'make-bitvector) (%inline-wasm '(func (param $len i32) (param $init i32) (result (ref eq)) (struct.new $mutable-bitvector (i32.const 0) (local.get $len) (array.new $raw-bitvector (local.get $init) (i32.add (i32.shr_u (i32.sub (local.get $len) (i32.const 1)) (i32.const 5)) (i32.const 1))))) len (match fill (#f 0) (#t -1)))) (define (bitvector-length bv) (check-type bv bitvector? 'bitvector-length) (%inline-wasm '(func (param $bv (ref $bitvector)) (result (ref eq)) (ref.i31 (i32.shl (struct.get $bitvector $len (local.get $bv)) (i32.const 1)))) bv)) (define (bitvector-ref bv i) (check-type bv bitvector? 'bitvector-ref) (check-index i (bitvector-length bv) 'bitvector-ref) (%inline-wasm '(func (param $bv (ref $bitvector)) (param $i i32) (result (ref eq)) (if (ref eq) (i32.and (array.get $raw-bitvector (struct.get $bitvector $vals (local.get $bv)) (i32.shr_s (local.get $i) (i32.const 5))) (i32.shl (i32.const 1) (local.get $i))) (then (ref.i31 (i32.const 17))) (else (ref.i31 (i32.const 1))))) bv i)) (define (bitvector-set-bit! bv i) (define (mutable-bitvector? x) (%inline-wasm '(func (param $bv (ref eq)) (result (ref eq)) (if (ref eq) (ref.test $mutable-bitvector (local.get $bv)) (then (ref.i31 (i32.const 17))) (else (ref.i31 (i32.const 1))))) x)) (check-type bv mutable-bitvector? 'bitvector-set-bit!) (check-index i (bitvector-length bv) 'bitvector-set-bit!) (%inline-wasm '(func (param $bv (ref $mutable-bitvector)) (param $i i32) (local $i0 i32) (local.set $i0 (i32.shr_s (local.get $i) (i32.const 5))) (array.set $raw-bitvector (struct.get $bitvector $vals (local.get $bv)) (local.get $i0) (i32.or (array.get $raw-bitvector (struct.get $bitvector $vals (local.get $bv)) (i32.shr_s (local.get $i) (i32.const 5))) (i32.shl (i32.const 1) (local.get $i))))) bv i)) ;; bitvector-set!, list->bitvector etc not yet implemented ) guile-hoot-0.7.0/lib/hoot/bitwise.scm000066400000000000000000000043651507574675700175220ustar00rootroot00000000000000;;; Bitwise arithmetic ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; R7RS (scheme cxr) implementation ;;; ;;; Code: (library (hoot bitwise) (export logand logior logxor lognot logtest logbit? logcount ash) (import (hoot errors) (hoot inline-wasm) (hoot syntax) (only (hoot primitives) apply %logand %logior %logxor %logtest %ash %exact-integer? %<= %-)) (define-syntax-rule (define-associative-eta-expansion f %f) (define f (case-lambda (() (%f)) ((x) (%f x)) ((x y) (%f x y)) ((x y . z) (apply f (%f x y) z))))) (define-associative-eta-expansion logand %logand) (define-associative-eta-expansion logior %logior) ;; FIXME: Tree-il doesn't lower single-arity logxor. ;(define-associative-eta-expansion logxor %logxor) (define logxor (case-lambda (() 0) ((x) (%logxor x 0)) ((x y) (%logxor x y)) ((x y . z) (apply logxor (%logxor x y) z)))) (define (lognot x) (%logxor x -1)) (define (logtest j k) (%logtest j k)) (define (logbit? idx k) (%logand k (%ash 1 idx))) (define (logcount x) (check-type x %exact-integer? 'logcount) (if (%<= (ash -1 29) x (%- (ash 1 29) 1)) ;; Fixnum fast path. (%inline-wasm '(func (param $x i64) (result i64) (i64.popcnt (local.get $x))) x) ;; Bignum slow path. (%inline-wasm '(func (param $x (ref $bignum)) (result i64) (i64.extend_i32_s (call $bignum-logcount (struct.get $bignum $val (local.get $x))))) x))) (define (ash x y) (%ash x y))) guile-hoot-0.7.0/lib/hoot/boxes.scm000066400000000000000000000024001507574675700171600ustar00rootroot00000000000000;;; Boxes ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Boxes. ;;; ;;; Code: (library (hoot boxes) (export box? make-box box-ref box-set!) (import (only (hoot primitives) %make-box %box-ref %box-set!) (hoot inline-wasm) (hoot syntax)) (define (box? x) (%inline-wasm '(func (param $x (ref eq)) (result (ref eq)) (if (ref eq) (ref.test $variable (local.get $x)) (then (ref.i31 (i32.const 17))) (else (ref.i31 (i32.const 1))))) x)) (define (make-box init) (%make-box init)) (define (box-ref box) (%box-ref box)) (define (box-set! box val) (%box-set! box val))) guile-hoot-0.7.0/lib/hoot/bytevectors.scm000066400000000000000000001337651507574675700204340ustar00rootroot00000000000000;;; Bytevectors ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Bytevectors. ;;; ;;; Code: (library (hoot bytevectors) (export make-bytevector bytevector-length bytevector-u8-ref bytevector-u8-set! bytevector-s8-ref bytevector-s8-set! bytevector-u16-ref bytevector-u16-native-ref bytevector-u16-set! bytevector-u16-native-set! bytevector-s16-ref bytevector-s16-native-ref bytevector-s16-set! bytevector-s16-native-set! bytevector-u32-ref bytevector-u32-native-ref bytevector-u32-set! bytevector-u32-native-set! bytevector-s32-ref bytevector-s32-native-ref bytevector-s32-set! bytevector-s32-native-set! bytevector-u64-ref bytevector-u64-native-ref bytevector-u64-set! bytevector-u64-native-set! bytevector-s64-ref bytevector-s64-native-ref bytevector-s64-set! bytevector-s64-native-set! bytevector-uint-ref bytevector-sint-ref bytevector-uint-set! bytevector-sint-set! bytevector-ieee-single-ref bytevector-ieee-single-native-ref bytevector-ieee-single-set! bytevector-ieee-single-native-set! bytevector-ieee-double-ref bytevector-ieee-double-native-ref bytevector-ieee-double-set! bytevector-ieee-double-native-set! bytevector? bytevector bytevector-concatenate bytevector-concatenate-reverse bytevector-append bytevector-copy bytevector-copy! bytevector-slice endianness native-endianness) (import (rename (only (hoot primitives) %null? %car %cdr %bytevector-length %bytevector? %bytevector-u8-ref %bytevector-u8-set! %bytevector-s8-ref %bytevector-s8-set! %bytevector-u16-native-ref %bytevector-u16-native-set! %bytevector-s16-native-ref %bytevector-s16-native-set! %bytevector-u32-native-ref %bytevector-u32-native-set! %bytevector-s32-native-ref %bytevector-s32-native-set! %bytevector-u64-native-ref %bytevector-u64-native-set! %bytevector-s64-native-ref %bytevector-s64-native-set! %bytevector-ieee-single-native-ref %bytevector-ieee-single-native-set! %bytevector-ieee-double-native-ref %bytevector-ieee-double-native-set! guile:make-bytevector guile:bytevector-copy!) (%null? null?) (%car car) (%cdr cdr)) (hoot cond-expand) (hoot errors) (hoot inline-wasm) (hoot match) (hoot numbers) (hoot syntax) (hoot syntax-objects) (hoot bitwise)) (define (bytevector? x) (%bytevector? x)) (define (bytevector-length bv) (%bytevector-length bv)) (cond-expand (guile-vm (define make-bytevector guile:make-bytevector)) (hoot (define* (make-bytevector len #:optional (init 0)) (check-size len (1- (ash 1 29)) 'make-bytevector) (check-range init -128 255 'make-bytevector) (%inline-wasm '(func (param $len i32) (param $init i32) (result (ref eq)) (struct.new $mutable-bytevector (i32.const 0) (array.new $raw-bytevector (local.get $init) (local.get $len)))) len init)))) (define (bytevector-u8-ref bv i) (%bytevector-u8-ref bv i)) (define (bytevector-u8-set! bv i x) (%bytevector-u8-set! bv i x)) (define (bytevector-s8-ref bv i) (%bytevector-s8-ref bv i)) (define (bytevector-s8-set! bv i x) (%bytevector-s8-set! bv i x)) (define (bytevector-u16-native-ref bv i) (%bytevector-u16-native-ref bv i)) (define (bytevector-u16-native-set! bv i x) (%bytevector-u16-native-set! bv i x)) (define (bytevector-s16-native-ref bv i) (%bytevector-s16-native-ref bv i)) (define (bytevector-s16-native-set! bv i x) (%bytevector-s16-native-set! bv i x)) (define (bytevector-u32-native-ref bv i) (%bytevector-u32-native-ref bv i)) (define (bytevector-u32-native-set! bv i x) (%bytevector-u32-native-set! bv i x)) (define (bytevector-s32-native-ref bv i) (%bytevector-s32-native-ref bv i)) (define (bytevector-s32-native-set! bv i x) (%bytevector-s32-native-set! bv i x)) (define (bytevector-u64-native-ref bv i) (%bytevector-u64-native-ref bv i)) (define (bytevector-u64-native-set! bv i x) (%bytevector-u64-native-set! bv i x)) (define (bytevector-s64-native-ref bv i) (%bytevector-s64-native-ref bv i)) (define (bytevector-s64-native-set! bv i x) (%bytevector-s64-native-set! bv i x)) (define (bytevector-ieee-single-native-ref bv i) (%bytevector-ieee-single-native-ref bv i)) (define (bytevector-ieee-single-native-set! bv i x) (%bytevector-ieee-single-native-set! bv i x)) (define (bytevector-ieee-double-native-ref bv i) (%bytevector-ieee-double-native-ref bv i)) (define (bytevector-ieee-double-native-set! bv i x) (%bytevector-ieee-double-native-set! bv i x)) (define-syntax endianness (lambda (x) (syntax-case x () ((_ sym) (match (syntax->datum #'sym) ((or 'big 'little) #''sym) (_ (syntax-violation 'endianness "unsupported endianness" #'sym))))))) (define (native-endianness) (endianness little)) (define (bytevector-u16-ref bv index endianness) (check-size index (- (bytevector-length bv) 2) 'bytevector-u16-ref) (match endianness ('little (bytevector-u16-native-ref bv index)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (result i64) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1))) (i32.shl (array.get_u $raw-bytevector (local.get $vu0) (local.get $idx)) (i32.const 8)) (i32.or) (i64.extend_i32_u)) bv index)))) (define (bytevector-u16-set! bv index value endianness) (check-size index (- (bytevector-length bv) 2) 'bytevector-u16-set!) (check-size value (1- (ash 1 16)) 'bytevector-u16-set!) (match endianness ('little (bytevector-u16-native-set! bv index value)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (param $value i32) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1)) (local.get $value)) (array.set $raw-bytevector (local.get $vu0) (local.get $idx) (i32.shr_u (local.get $value) (i32.const 8)))) bv index value)))) (define (bytevector-s16-ref bv index endianness) (check-size index (- (bytevector-length bv) 2) 'bytevector-s16-ref) (match endianness ('little (bytevector-s16-native-ref bv index)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (result i64) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1))) (i32.shl (array.get_s $raw-bytevector (local.get $vu0) (local.get $idx)) (i32.const 8)) (i32.or) (i64.extend_i32_s)) bv index)))) (define (bytevector-s16-set! bv index value endianness) (check-size index (- (bytevector-length bv) 2) 'bytevector-s16-set!) (check-range value (ash -1 15) (1- (ash 1 15)) 'bytevector-s16-set!) (match endianness ('little (bytevector-u16-native-set! bv index value)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (param $value i32) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1)) (local.get $value)) (array.set $raw-bytevector (local.get $vu0) (local.get $idx) (i32.shr_s (local.get $value) (i32.const 8)))) bv index value)))) (define (bytevector-u32-ref bv index endianness) (check-size index (- (bytevector-length bv) 4) 'bytevector-u32-ref) (match endianness ('little (bytevector-u32-native-ref bv index)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (result i64) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 3))) (i32.shl (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 2))) (i32.const 8)) (i32.or) (i32.shl (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1))) (i32.const 16)) (i32.or) (i32.shl (array.get_u $raw-bytevector (local.get $vu0) (local.get $idx)) (i32.const 24)) (i32.or) (i64.extend_i32_u)) bv index)))) (define (bytevector-u32-set! bv index value endianness) (check-size index (- (bytevector-length bv) 4) 'bytevector-u32-set!) (check-size value (1- (ash 1 32)) 'bytevector-u32-set!) (match endianness ('little (bytevector-u32-native-set! bv index value)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (param $value i32) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 3)) (local.get $value)) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 2)) (i32.shr_u (local.get $value) (i32.const 8))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1)) (i32.shr_u (local.get $value) (i32.const 16))) (array.set $raw-bytevector (local.get $vu0) (local.get $idx) (i32.shr_u (local.get $value) (i32.const 24)))) bv index value)))) (define (bytevector-s32-ref bv index endianness) (check-size index (- (bytevector-length bv) 4) 'bytevector-s32-ref) (match endianness ('little (bytevector-s32-native-ref bv index)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (result i64) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 3))) (i32.shl (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 2))) (i32.const 8)) (i32.or) (i32.shl (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1))) (i32.const 16)) (i32.or) (i32.shl (array.get_s $raw-bytevector (local.get $vu0) (local.get $idx)) (i32.const 24)) (i32.or) (i64.extend_i32_s)) bv index)))) (define (bytevector-s32-set! bv index value endianness) (check-size index (- (bytevector-length bv) 4) 'bytevector-s32-set!) (check-range value (ash -1 31) (1- (ash 1 31)) 'bytevector-s32-set!) (match endianness ('little (bytevector-s32-native-set! bv index value)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (param $value i32) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 3)) (local.get $value)) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 2)) (i32.shr_u (local.get $value) (i32.const 8))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1)) (i32.shr_u (local.get $value) (i32.const 16))) (array.set $raw-bytevector (local.get $vu0) (local.get $idx) (i32.shr_s (local.get $value) (i32.const 24)))) bv index value)))) (define (bytevector-u64-ref bv index endianness) (check-size index (- (bytevector-length bv) 8) 'bytevector-u64-ref) (match endianness ('little (bytevector-u64-native-ref bv index)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (result i64) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 7)))) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 6)))) (i64.const 8)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 5)))) (i64.const 16)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 4)))) (i64.const 24)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 3)))) (i64.const 32)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 2)))) (i64.const 40)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1)))) (i64.const 48)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (local.get $idx))) (i64.const 56)) (i64.or)) bv index)))) (define (bytevector-u64-set! bv index value endianness) (check-size index (- (bytevector-length bv) 4) 'bytevector-u64-set!) (check-size value (1- (ash 1 64)) 'bytevector-u64-set!) (match endianness ('little (bytevector-u64-native-set! bv index value)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (param $value i64) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 7)) (i32.wrap_i64 (local.get $value))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 6)) (i32.wrap_i64 (i64.shr_u (local.get $value) (i64.const 8)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 5)) (i32.wrap_i64 (i64.shr_u (local.get $value) (i64.const 16)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 4)) (i32.wrap_i64 (i64.shr_u (local.get $value) (i64.const 24)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 3)) (i32.wrap_i64 (i64.shr_u (local.get $value) (i64.const 32)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 2)) (i32.wrap_i64 (i64.shr_u (local.get $value) (i64.const 40)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1)) (i32.wrap_i64 (i64.shr_u (local.get $value) (i64.const 48)))) (array.set $raw-bytevector (local.get $vu0) (local.get $idx) (i32.wrap_i64 (i64.shr_u (local.get $value) (i64.const 56))))) bv index value)))) (define (bytevector-s64-ref bv index endianness) (check-size index (- (bytevector-length bv) 8) 'bytevector-s64-ref) (match endianness ('little (bytevector-s64-native-ref bv index)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (result i64) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 7)))) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 6)))) (i64.const 8)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 5)))) (i64.const 16)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 4)))) (i64.const 24)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 3)))) (i64.const 32)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 2)))) (i64.const 40)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1)))) (i64.const 48)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_s $raw-bytevector (local.get $vu0) (local.get $idx))) (i64.const 56)) (i64.or)) bv index)))) (define (bytevector-s64-set! bv index value endianness) (check-size index (- (bytevector-length bv) 4) 'bytevector-s64-set!) (check-range value (ash -1 63) (1- (ash 1 63)) 'bytevector-s64-set!) (match endianness ('little (bytevector-s64-native-set! bv index value)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (param $value i64) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 7)) (i32.wrap_i64 (local.get $value))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 6)) (i32.wrap_i64 (i64.shr_u (local.get $value) (i64.const 8)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 5)) (i32.wrap_i64 (i64.shr_u (local.get $value) (i64.const 16)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 4)) (i32.wrap_i64 (i64.shr_u (local.get $value) (i64.const 24)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 3)) (i32.wrap_i64 (i64.shr_u (local.get $value) (i64.const 32)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 2)) (i32.wrap_i64 (i64.shr_u (local.get $value) (i64.const 40)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1)) (i32.wrap_i64 (i64.shr_u (local.get $value) (i64.const 48)))) (array.set $raw-bytevector (local.get $vu0) (local.get $idx) (i32.wrap_i64 (i64.shr_s (local.get $value) (i64.const 56))))) bv index value)))) (define (bytevector-uint-ref bv index endianness size) (check-size index (- (bytevector-length bv) size) 'bytevector-uint-ref) (match endianness ('little (case size ((1) (bytevector-u8-ref bv index)) ((2) (bytevector-u16-native-ref bv index)) ((4) (bytevector-u32-native-ref bv index)) ((8) (bytevector-u64-native-ref bv index)) (else (let lp ((i 0)) (if (= i size) 0 (logior (ash (bytevector-u8-ref bv (+ index i)) (* i 8)) (lp (1+ i)))))))) ('big (case size ((1) (bytevector-u8-ref bv index)) ((2) (bytevector-u16-ref bv index endianness)) ((4) (bytevector-u32-ref bv index endianness)) ((8) (bytevector-u64-ref bv index endianness)) (else (let lp ((i 0)) (if (= i size) 0 (logior (ash (bytevector-u8-ref bv (+ index (- size 1 i))) (* i 8)) (lp (1+ i)))))))))) (define (bytevector-uint-set! bv index value endianness size) (check-size index (- (bytevector-length bv) size) 'bytevector-uint-set!) (check-size value (1- (ash 1 (* size 8))) 'bytevector-uint-set!) (match endianness ('little (case size ((1) (bytevector-u8-set! bv index value)) ((2) (bytevector-u16-native-set! bv index value)) ((4) (bytevector-u32-native-set! bv index value)) ((8) (bytevector-u64-native-set! bv index value)) (else (let lp ((i 0)) (unless (= i size) (bytevector-u8-set! bv (+ index i) (logand #xff (ash value (- (* i 8))))) (lp (1+ i))))))) ('big (case size ((1) (bytevector-u8-set! bv index value)) ((2) (bytevector-u16-set! bv index endianness value)) ((4) (bytevector-u32-set! bv index endianness value)) ((8) (bytevector-u64-set! bv index endianness value)) (else (let lp ((i 0)) (unless (= i size) (bytevector-u8-set! bv (+ index (- size 1 i)) (logand #xff (ash value (- (* i 8))))) (lp (1+ i))))))))) (define (bytevector-sint-ref bv index endianness size) (check-size index (- (bytevector-length bv) size) 'bytevector-sint-ref) (match endianness ('little (case size ((1) (bytevector-s8-ref bv index)) ((2) (bytevector-s16-native-ref bv index)) ((4) (bytevector-s32-native-ref bv index)) ((8) (bytevector-s64-native-ref bv index)) (else (let lp ((i 0)) (if (= i (1- size)) (ash (bytevector-s8-ref bv (+ index i)) (* i 8)) (logior (ash (bytevector-u8-ref bv (+ index i)) (* i 8)) (lp (1+ i)))))))) ('big (case size ((1) (bytevector-s8-ref bv index)) ((2) (bytevector-s16-ref bv index endianness)) ((4) (bytevector-s32-ref bv index endianness)) ((8) (bytevector-s64-ref bv index endianness)) (else (let ((k (1- size))) (let lp ((i 0)) (if (= i k) (ash (bytevector-s8-ref bv (+ index (- k i))) (* i 8)) (logior (ash (bytevector-u8-ref bv (+ index (- k i))) (* i 8)) (lp (1+ i))))))))))) (define (bytevector-sint-set! bv index value endianness size) (check-size index (- (bytevector-length bv) size) 'bytevector-sint-set!) (check-range value (ash -1 (1- (* size 8))) (1- (ash 1 (1- (* size 8)))) 'bytevector-sint-set!) (match endianness ('little (case size ((1) (bytevector-u8-set! bv index value)) ((2) (bytevector-u16-native-set! bv index value)) ((4) (bytevector-u32-native-set! bv index value)) ((8) (bytevector-u64-native-set! bv index value)) (else (let lp ((i 0)) (cond ((= i (1- size)) (bytevector-s8-set! bv (+ index i) (ash value (- (* i 8))))) (else (bytevector-u8-set! bv (+ index i) (logand #xff (ash value (- (* i 8))))) (lp (1+ i)))))))) ('big (case size ((1) (bytevector-u8-set! bv index value)) ((2) (bytevector-u16-set! bv index endianness value)) ((4) (bytevector-u32-set! bv index endianness value)) ((8) (bytevector-u64-set! bv index endianness value)) (else (let ((k (1- size))) (let lp ((i 0)) (cond ((= i k) (bytevector-s8-set! bv (+ index (- k i)) (ash value (- (* i 8))))) (else (bytevector-u8-set! bv (+ index (- k i)) (logand #xff (ash value (- (* i 8))))) (lp (1+ i))))))))))) (define (bytevector-ieee-single-ref bv index endianness) (check-size index (- (bytevector-length bv) 4) 'bytevector-ieee-single-ref) (match endianness ('little (bytevector-ieee-single-native-ref bv index)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (result f64) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 3))) (i32.shl (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 2))) (i32.const 8)) (i32.or) (i32.shl (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1))) (i32.const 16)) (i32.or) (i32.shl (array.get_u $raw-bytevector (local.get $vu0) (local.get $idx)) (i32.const 24)) (i32.or) (f32.reinterpret_i32) (f64.promote_f32)) bv index)))) (define (bytevector-ieee-single-set! bv index value endianness) (check-size index (- (bytevector-length bv) 4) 'bytevector-ieee-single-set!) (match endianness ('little (bytevector-ieee-single-native-set! bv index value)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (param $value f32) (local $vu0 (ref $raw-bytevector)) (local $i0 i32) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (local.set $i0 (i32.reinterpret_f32 (local.get $value))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 3)) (local.get $i0)) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 2)) (i32.shr_u (local.get $i0) (i32.const 8))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1)) (i32.shr_u (local.get $i0) (i32.const 16))) (array.set $raw-bytevector (local.get $vu0) (local.get $idx) (i32.shr_u (local.get $i0) (i32.const 24)))) bv index value)))) (define (bytevector-ieee-double-ref bv index endianness) (check-size index (- (bytevector-length bv) 4) 'bytevector-ieee-double-ref) (match endianness ('little (bytevector-ieee-double-native-ref bv index)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (result f64) (local $vu0 (ref $raw-bytevector)) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 7)))) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 6)))) (i64.const 8)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 5)))) (i64.const 16)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 4)))) (i64.const 24)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 3)))) (i64.const 32)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 2)))) (i64.const 40)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1)))) (i64.const 48)) (i64.or) (i64.shl (i64.extend_i32_u (array.get_u $raw-bytevector (local.get $vu0) (local.get $idx))) (i64.const 56)) (i64.or) (f64.reinterpret_i64)) bv index)))) (define (bytevector-ieee-double-set! bv index value endianness) (check-size index (- (bytevector-length bv) 4) 'bytevector-ieee-double-set!) (match endianness ('little (bytevector-ieee-double-native-set! bv index value)) ('big (%inline-wasm '(func (param $bv (ref $bytevector)) (param $idx i32) (param $value f64) (local $vu0 (ref $raw-bytevector)) (local $j0 i64) (local.set $vu0 (struct.get $bytevector $vals (local.get $bv))) (local.set $j0 (i64.reinterpret_f64 (local.get $value))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 7)) (i32.wrap_i64 (local.get $j0))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 6)) (i32.wrap_i64 (i64.shr_u (local.get $j0) (i64.const 8)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 5)) (i32.wrap_i64 (i64.shr_u (local.get $j0) (i64.const 16)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 4)) (i32.wrap_i64 (i64.shr_u (local.get $j0) (i64.const 24)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 3)) (i32.wrap_i64 (i64.shr_u (local.get $j0) (i64.const 32)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 2)) (i32.wrap_i64 (i64.shr_u (local.get $j0) (i64.const 40)))) (array.set $raw-bytevector (local.get $vu0) (i32.add (local.get $idx) (i32.const 1)) (i32.wrap_i64 (i64.shr_u (local.get $j0) (i64.const 48)))) (array.set $raw-bytevector (local.get $vu0) (local.get $idx) (i32.wrap_i64 (i64.shr_u (local.get $j0) (i64.const 56))))) bv index value)))) (define (bytevector . inits) (define (length l) (let lp ((len 0) (l l)) (if (null? l) len (lp (+ len 1) (cdr l))))) (let* ((len (length inits)) (bv (make-bytevector len))) (let lp ((i 0) (inits inits)) (when (< i len) (bytevector-u8-set! bv i (car inits)) (lp (1+ i) (cdr inits)))) bv)) (define (bytevector-length* bv*) (let lp ((bv* bv*) (len 0)) (match bv* (() len) ((bv . bv*) (lp bv* (+ len (bytevector-length bv))))))) (define (bytevector-concatenate bv*) (match bv* (() #vu8()) ((bv) bv) (bv* (let* ((len (bytevector-length* bv*)) (flattened (make-bytevector len 0))) (let lp ((bv* bv*) (cur 0)) (match bv* (() flattened) ((bv . bv*) (bytevector-copy! flattened cur bv) (lp bv* (+ cur (bytevector-length bv)))))))))) (define (bytevector-concatenate-reverse bv*) (match bv* (() #vu8()) ((bv) bv) (bv* (let* ((len (bytevector-length* bv*)) (flattened (make-bytevector len 0))) (let lp ((bv* bv*) (cur len)) (match bv* (() flattened) ((bv . bv*) (let ((cur (- cur (bytevector-length bv)))) (bytevector-copy! flattened cur bv) (lp bv* cur))))))))) (define (bytevector-append . args) (bytevector-concatenate args)) (cond-expand (guile-vm (define* (bytevector-copy x #:optional (start 0) (end (bytevector-length x))) (let* ((len (- end start)) (new (make-bytevector len))) (guile:bytevector-copy! x start new 0 len) new)) (define* (bytevector-copy! to at from #:optional (start 0) (end (bytevector-length from))) (guile:bytevector-copy! from start to at (- end start)))) (hoot (define* (bytevector-copy x #:optional (start 0) (end (bytevector-length x))) (check-type x bytevector? 'bytevector-copy) (check-range start 0 (bytevector-length x) 'bytevector-copy) (check-range end start (bytevector-length x) 'bytevector-copy) (%inline-wasm '(func (param $src (ref $bytevector)) (param $start i32) (param $end i32) (result (ref eq)) (local $i0 i32) (local $vu0 (ref $raw-bytevector)) (local.set $i0 (i32.sub (local.get $end) (local.get $start))) (local.set $vu0 (array.new_default $raw-bytevector (local.get $i0))) (array.copy $raw-bytevector $raw-bytevector (local.get $vu0) (i32.const 0) (struct.get $bytevector $vals (local.get $src)) (local.get $start) (local.get $i0)) (struct.new $bytevector (i32.const 0) (local.get $vu0))) x start end)) (define* (bytevector-copy! to at from #:optional (start 0) (end (bytevector-length from))) ;; FIXME: check that `to` is mutable (check-type to bytevector? 'bytevector-copy!) (check-range at 0 (bytevector-length to) 'bytevector-copy!) (check-type from bytevector? 'bytevector-copy!) (check-range start 0 (bytevector-length from) 'bytevector-copy!) (check-range end start (bytevector-length from) 'bytevector-copy!) (%inline-wasm '(func (param $to (ref $mutable-bytevector)) (param $at i32) (param $from (ref $bytevector)) (param $start i32) (param $end i32) (array.copy $raw-bytevector $raw-bytevector (struct.get $mutable-bytevector $vals (local.get $to)) (local.get $at) (struct.get $bytevector $vals (local.get $from)) (local.get $start) (i32.sub (local.get $end) (local.get $start)))) to at from start end)))) (define* (bytevector-slice bv offset #:optional (size (- (bytevector-length bv) offset))) (raise (make-unimplemented-error 'bytevector-slice)))) guile-hoot-0.7.0/lib/hoot/char.scm000066400000000000000000000063551507574675700167720ustar00rootroot00000000000000;;; (hoot chars) library ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Basic parts of (scheme chars). ;;; ;;; Code: (library (hoot char) (export char->integer integer->char char? char=? char>? char-upcase char-downcase char-alphabetic? char-lower-case? char-numeric? char-upper-case? char-whitespace? string-upcase string-downcase) (import (rename (only (hoot primitives) %+ %- %string? %vector-ref %< %<= %= %>= %> %char->integer %integer->char %char?) (%+ +) (%- -) (%string? string?) (%vector-ref vector-ref) (%< <) (%<= <=) (%= =) (%>= >=) (%> >)) (hoot bitvectors) (hoot bitwise) (hoot errors) (hoot inline-wasm) (hoot match) (hoot syntax)) (define (char->integer x) (%char->integer x)) (define (integer->char x) (%integer->char x)) (define (char? x) (%char? x)) (define-syntax-rule (define-comparison-expansion name cmp) (define name (case-lambda ((a b) (cmp a b)) ((a b . c) (let lp ((res (cmp a b)) (a b) (c c)) (match c (() res) ((b . c) (lp (and (cmp a b) res) b c)))))))) (define-syntax-rule (define-char-comparison-expansion name cmp) (define-comparison-expansion name (lambda (a b) (cmp (char->integer a) (char->integer b))))) (define-char-comparison-expansion char=? >=) (define-char-comparison-expansion char>? >) ;; generated (scheme char) procedures: ;; char-upcase ;; char-downcase ;; char-upper-case? ;; char-lower-case? ;; char-alphabetic? ;; char-numeric? ;; char-whitespace? (include-from-path "hoot/char-prelude") (define (string-upcase str) (check-type str string? 'string-upcase) (%inline-wasm '(func (param $str (ref string)) (result (ref eq)) (struct.new $string (i32.const 0) (call $string-upcase (local.get $str)))) str)) (define (string-downcase str) (check-type str string? 'string-downcase) (%inline-wasm '(func (param $str (ref string)) (result (ref eq)) (struct.new $string (i32.const 0) (call $string-downcase (local.get $str)))) str))) guile-hoot-0.7.0/lib/hoot/cond-expand.scm000066400000000000000000000044241507574675700202500ustar00rootroot00000000000000;;; R7RS cond-expand library ;;; Copyright (C) 2024, 2025 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; R7RS cond-expand implementation ;;; ;;; Code: (library (hoot cond-expand) (export cond-expand) (import (hoot features) (hoot syntax) (only (hoot primitives) %eq? %car %cdr %cons %syntax->datum target-runtime)) (define-syntax cond-expand (lambda (x) (define (has-req? req) (syntax-case req (and or) ((and req ...) (let lp ((reqs #'(req ...))) (or (%eq? reqs '()) (and (has-req? (%car reqs)) (lp (%cdr reqs)))))) ((or req ...) (let lp ((reqs #'(req ...))) (if (%eq? reqs '()) #f (or (has-req? (%car reqs)) (lp (%cdr reqs)))))) ((not req) (%eq? (%syntax->datum #'not) 'not) (if (has-req? #'req) #f #t)) ((library lib-name) (%eq? (%syntax->datum #'library) 'library) ;; FIXME: No libraries, for the time being. #f) (id (identifier? #'id) (let ((req (%syntax->datum #'id))) (let lp ((features (%cons (target-runtime) (features)))) (if (%eq? features '()) #f (or (%eq? req (%car features)) (lp (%cdr features))))))))) (syntax-case x (else) ((_) (syntax-violation 'cond-expand "Unfulfilled cond-expand" x)) ((_ (else body ...)) #'(begin body ...)) ((_ (req body ...) more-clauses ...) (if (has-req? #'req) #'(begin body ...) #'(cond-expand more-clauses ...))))))) guile-hoot-0.7.0/lib/hoot/control.scm000066400000000000000000000065511507574675700175330ustar00rootroot00000000000000;;; Delimited control ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Delimited control. ;;; ;;; Code: (library (hoot control) (export make-prompt-tag default-prompt-tag call-with-prompt abort-to-prompt % default-prompt-handler call-with-current-continuation call/cc) (import (hoot apply) (hoot cond-expand) (hoot inline-wasm) (hoot parameters) (rename (only (hoot primitives) %cons %abort-to-prompt %call-with-prompt) (%abort-to-prompt abort-to-prompt)) (hoot syntax) (hoot values)) (define* (make-prompt-tag #:optional (stem "prompt")) (%cons stem '())) (cond-expand (guile-vm) (hoot (define default-prompt-tag (%inline-wasm '(func (result (ref eq)) (global.get $default-prompt-tag)))))) (define-syntax-rule (define-primcall f %f arg ...) (begin (define (generic arg ...) (%f arg ...)) (define-syntax f (lambda (stx) (syntax-case stx () ((_ . x) #'(%f . x)) (id (identifier? #'id) #'generic)))))) (define-primcall call-with-prompt %call-with-prompt tag body handler) (define-syntax % (syntax-rules () ((_ expr) (call-with-prompt (default-prompt-tag) (lambda () expr) default-prompt-handler)) ((_ expr handler) (call-with-prompt (default-prompt-tag) (lambda () expr) handler)) ((_ tag expr handler) (call-with-prompt tag (lambda () expr) handler)))) (define (default-prompt-handler k proc) (% (proc k))) ;; This is an implementation of call/cc in terms of delimited ;; continuations. It correct except as regards dynamic-wind: capturing ;; the continuation unwinds all dynamic-winds, then rewinds them; and ;; invoking the continuation does the same, even if the invoking and ;; captured continuations overlap. Oh well; call/cc is strictly less ;; useful than call-with-prompt anyway. (define (call-with-current-continuation proc) (define (unwind-and-call handler) (abort-to-prompt (default-prompt-tag) handler)) (define (rewind-and-continue captured-continuation) (define-syntax-rule (reinstate expr) (captured-continuation (lambda () expr))) (define (k . args) (define (rewind-and-return-values discarded-continuation) (reinstate (apply values args))) (unwind-and-call rewind-and-return-values)) (reinstate (proc k))) (let ((thunk (unwind-and-call rewind-and-continue))) (thunk))) (define call/cc call-with-current-continuation)) guile-hoot-0.7.0/lib/hoot/core-syntax-helpers.scm000066400000000000000000000041451507574675700217640ustar00rootroot00000000000000;;; Syntax helper procedures ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Primitive syntax. ;;; ;;; Code: (library (hoot core-syntax-helpers) (export make-variable-transformer identifier? generate-temporaries free-identifier=? bound-identifier=? syntax-local-binding syntax-violation %initialize-syntax-helpers!) (import (hoot core-syntax) (hoot cross-compilation) (prefix (only (hoot primitives) make-variable-transformer identifier? generate-temporaries free-identifier=? bound-identifier=? syntax-local-binding syntax-violation) host:)) (define-syntax-rule (define-syntax-helper name host-name) (define name (cross-compilation-case (#t host-name) (#f #f)))) (define-syntax-rule (define-syntax-helpers initialize! (name host-name) ...) (begin (define-syntax-helper name host-name) ... (define (do-init host-name ...) (set! name host-name) ...) (define* (initialize! #:key name ...) (do-init name ...)))) (define-syntax-helpers %initialize-syntax-helpers! (make-variable-transformer host:make-variable-transformer) (identifier? host:identifier?) (generate-temporaries host:generate-temporaries) (free-identifier=? host:free-identifier=?) (bound-identifier=? host:bound-identifier=?) (syntax-local-binding host:syntax-local-binding) (syntax-violation host:syntax-violation))) guile-hoot-0.7.0/lib/hoot/core-syntax.scm000066400000000000000000000023451507574675700203240ustar00rootroot00000000000000;;; Core syntax ;;; Copyright (C) 2024, 2025 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Core syntax. ;;; ;;; Code: (library (hoot core-syntax) (export _ ... => else lambda case-lambda define lambda* case-lambda* define* let let* letrec letrec* begin if set! or and cond case when unless do quote quasiquote unquote unquote-splicing define-syntax let-syntax letrec-syntax syntax-rules syntax-error define-syntax-rule syntax-case syntax quasisyntax unsyntax unsyntax-splicing quote-syntax with-syntax identifier-syntax include include-ci include-from-path) (import (hoot primitives))) guile-hoot-0.7.0/lib/hoot/cross-compilation.scm000066400000000000000000000025261507574675700215160ustar00rootroot00000000000000;;; Cross-compilation-case ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; A limited form of cond-expand, just for selecting code according to ;;; whether we are cross-compiling or not. ;;; ;;; Code: (library (hoot cross-compilation) (export cross-compilation-case) (import (hoot core-syntax) (only (hoot primitives) target-runtime)) (define-syntax cross-compilation-case (lambda (stx) (syntax-case stx () ((_) #'(begin)) ((_ (#f . body) . clauses) (case (target-runtime) ((hoot) #'(begin . body)) (else #'(cross-compilation-case . clauses)))) ((_ (#t . body) . clauses) (case (target-runtime) ((hoot) #'(cross-compilation-case . clauses)) (else #'(begin . body)))))))) guile-hoot-0.7.0/lib/hoot/debug.scm000066400000000000000000000067151507574675700171430ustar00rootroot00000000000000;;; Debugging utilities ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Backtraces and so on. ;;; ;;; Code: (library (hoot debug) (export dprint pk backtrace) (import (only (hoot primitives) %+ %- %<= guile:pk) (hoot cross-compilation) (hoot inline-wasm) (hoot match) (hoot syntax)) (define (1+ x) (%+ x 1)) (define (1- x) (%- x 1)) (define (- x y) (%- x y)) (define (<= x y) (%<= x y)) (define dprint (case-lambda ((message) (%inline-wasm '(func (param $str (ref string)) (call $debug-str (local.get $str))) message)) ((message val) (%inline-wasm '(func (param $str (ref string)) (param $val (ref eq)) (call $debug-str-scm (local.get $str) (local.get $val))) message val)))) (define pk (cross-compilation-case (#t guile:pk) (#f (lambda (v . v*) (let lp ((v v) (v* v*)) (match v* (() (dprint "pkv" v) v) ((v* . v**) (dprint "pk_" v) (lp v* v**)))))))) (define (backtrace) (define (scm-sp) (%inline-wasm '(func (result (ref eq)) (ref.i31 (i32.shl (global.get $scm-sp) (i32.const 1)))))) (define (raw-sp) (%inline-wasm '(func (result (ref eq)) (ref.i31 (i32.shl (global.get $raw-sp) (i32.const 1)))))) (define (ret-sp) (%inline-wasm '(func (result (ref eq)) (ref.i31 (i32.shl (global.get $ret-sp) (i32.const 1)))))) (define (dyn-sp) (%inline-wasm '(func (result (ref eq)) (ref.i31 (i32.shl (global.get $dyn-sp) (i32.const 1)))))) (define (scm-ref n) (%inline-wasm '(func (param $n (ref i31)) (result (ref eq)) (ref.as_non_null (table.get $scm-stack (i32.shr_s (i31.get_s (local.get $n)) (i32.const 1))))) n)) (define (raw-ref n) (%inline-wasm '(func (param $n (ref i31)) (result (ref eq)) (ref.i31 (i32.shl (i32.load8_s $raw-stack (i32.shr_s (i31.get_s (local.get $n)) (i32.const 1))) (i32.const 1)))) n)) (let ((scm-sp (scm-sp)) (raw-sp (raw-sp)) (ret-sp (ret-sp)) (dyn-sp (dyn-sp))) (dprint "scm backtrace" scm-sp) (let lp ((i 1)) (when (<= 0 (- scm-sp i)) (dprint "scm" (scm-ref (- scm-sp i))) (lp (1+ i)))) (dprint "raw backtrace" raw-sp) (let lp ((i 1)) (when (<= 0 (- raw-sp i)) (dprint "raw" (raw-ref (- raw-sp i))) (lp (1+ i)))) (dprint "ret stack height" ret-sp) (dprint "dyn stack height" dyn-sp) (dprint "")))) guile-hoot-0.7.0/lib/hoot/dynamic-states.scm000066400000000000000000000060711507574675700207750ustar00rootroot00000000000000;;; Dynamic states ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Dynamic states. ;;; ;;; Code: (library (hoot dynamic-states) (export current-dynamic-state dynamic-state? with-dynamic-state) (import (only (hoot primitives) %with-dynamic-state) (hoot debug) (hoot errors) (hoot inline-wasm) (hoot lists) (hoot match) (hoot numbers) (hoot syntax) (hoot values) (hoot vectors)) (define (copy-alist alist) (match alist (() (values '() 0)) (((k . v) . alist) (call-with-values (lambda () (copy-alist alist)) (lambda (alist len) (values (acons k v alist) (1+ len))))))) (define (copy-hash-table table) (define buckets (%inline-wasm '(func (param $table (ref $hash-table)) (result (ref eq)) (struct.new $vector (i32.const 0) (struct.get $hash-table $buckets (local.get $table)))) table)) (define nbuckets (vector-length buckets)) (define buckets* (make-vector nbuckets '())) (let lp ((i 0) (size 0)) (cond ((< i nbuckets) (call-with-values (lambda () (copy-alist (vector-ref buckets i))) (lambda (bucket len) (vector-set! buckets* i bucket) (lp (1+ i) (+ size len))))) (else (%inline-wasm '(func (param $buckets (ref $vector)) (param $size i32) (result (ref eq)) (struct.new $hash-table (i32.const 0) (local.get $size) (struct.get $vector $vals (local.get $buckets)))) buckets* size))))) (define (current-dynamic-state) (define current-fluids (%inline-wasm '(func (result (ref eq)) (global.get $current-fluids)))) (%inline-wasm '(func (param $fluids (ref $hash-table)) (result (ref eq)) (struct.new $dynamic-state (i32.const 0) (local.get $fluids))) (copy-hash-table current-fluids))) (define (dynamic-state? x) (%inline-wasm '(func (param $x (ref eq)) (result (ref eq)) (if (ref eq) (ref.test $dynamic-state (local.get $x)) (then (ref.i31 (i32.const 17))) (else (ref.i31 (i32.const 1))))) x)) (define (with-dynamic-state state thunk) (check-type state dynamic-state? 'with-dynamic-state) (%with-dynamic-state state thunk))) guile-hoot-0.7.0/lib/hoot/dynamic-wind.scm000066400000000000000000000016561507574675700204370ustar00rootroot00000000000000;;; Dynamic wind ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Dynamic wind. ;;; ;;; Code: (library (hoot dynamic-wind) (export dynamic-wind) (import (only (hoot primitives) %dynamic-wind) (hoot syntax)) (define (dynamic-wind wind body unwind) (%dynamic-wind (lambda () (wind)) (lambda () (body)) (lambda () (unwind))))) guile-hoot-0.7.0/lib/hoot/environments.scm000066400000000000000000000115061507574675700205760ustar00rootroot00000000000000;;; Modules ;;; Copyright (C) 2024, 2025 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Run-time representation of module trees. ;;; ;;; Code: (library (hoot environments) (export environment) (import (hoot assoc) (hoot cond-expand) (hoot errors) (hoot exceptions) (hoot gensym) (hoot lists) (hoot modules) (hoot not) (hoot numbers) (hoot pairs) (hoot strings) (hoot symbols) (hoot syntax) (hoot values) (ice-9 match)) (define-exception-type &unknown-module &violation make-unknown-module-error unknown-module-error? (name unknown-module-name)) (define (load-module root name) #f) (define (environment . import-sets) (define root (the-root-module)) (unless root (cond-expand (runtime-modules (error "No root module even though -gruntime-modules, WTF?")) (else (error "No run-time module registry; recompile with -g")))) (define (id? x) (symbol? x)) (define (name-component? x) (id? x)) (define (version-component? x) (and (exact-integer? x) (not (negative? x)))) (define parse-name+version (match-lambda (((? name-component? name) ... ((? version-component? version) ...)) (values name version)) (((? name-component? name) ...) (values name '())))) (define (symbol-append a b) (string->symbol (string-append (symbol->string a) (symbol->string b)))) (define (make-interface src) (make-empty-module #:name (module-name src) #:root root)) (define parse-import-set (match-lambda ((head . tail) (match head ('only (match tail ((iset (? id? select) ...) (let* ((src (parse-import-set iset)) (dst (make-interface src))) (for-each (lambda (id) (module-import! dst src id) (module-export! dst id)) select) dst)))) ('except (match tail ((iset (? id? hide) ...) (let* ((src (parse-import-set iset)) (dst (make-interface src))) (for-each (lambda (id) (unless (memq id hide) (module-import! dst src id) (module-export! dst id))) (module-exported-names src)) dst)))) ('prefix (match tail ((iset (? id? prefix)) (let* ((src (parse-import-set iset)) (dst (make-interface src))) (for-each (lambda (id) (module-import! dst src id) (module-export! dst (symbol-append prefix id) id)) (module-exported-names src)) dst)))) ('rename (match tail ((iset ((? id? from) (? id? to)) ...) (let* ((src (parse-import-set iset)) (dst (make-interface src)) (trans (map cons from to))) (for-each (lambda (id) (module-import! dst src id) (module-export! dst (or (assq-ref trans id) id) id)) (module-exported-names src)) dst)))) ('library (match tail ((name+version) (call-with-values (lambda () (parse-name+version name+version)) (lambda (name version) (or (resolve-module root name) (load-module root name) (raise-exception (make-unknown-module-error name)))))))) (_ (parse-import-set `(library (,head . ,tail)))))))) (let ((env (make-empty-module #:name (list (gensym)) #:root root))) (for-each (lambda (iset) (let ((src (parse-import-set iset))) (for-each (lambda (id) (module-import! env src id)) (module-exported-names src)))) import-sets) env))) guile-hoot-0.7.0/lib/hoot/eq.scm000066400000000000000000000016221507574675700164520ustar00rootroot00000000000000;;; Eq, eqv ;;; Copyright (C) 2023, 2024 Igalia, S.L. ;;; Copyright (C) 2023 Robin Templeton ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; eq? and eqv? ;;; ;;; Code: (library (hoot eq) (export eq? eqv?) (import (only (hoot primitives) %eq? %eqv?) (hoot syntax)) (define (eq? x y) (%eq? x y)) (define (eqv? x y) (%eqv? x y))) guile-hoot-0.7.0/lib/hoot/equal.scm000066400000000000000000000327351507574675700171650ustar00rootroot00000000000000;;; Equal? ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Implementation of 'equal?' based on the interleaved union-find and ;;; tree equality with precheck algorithm from "Efficient ;;; Nondestructive Equality Checking for Trees and Graphs" ;;; ;;; See: https://cs.indiana.edu/~dyb/pubs/equal.pdf ;;; ;;; Code: (library (hoot equal) (export equal?) (import (hoot bitvectors) (hoot bytevectors) (hoot boxes) (hoot eq) (hoot inline-wasm) (hoot match) (hoot numbers) (hoot not) (hoot pairs) (only (hoot primitives) %struct-ref %struct-vtable) (hoot records) (hoot strings) (hoot syntax) (hoot values) (hoot vectors)) (define (equal? x y) ;; TODO: Add pseudorandom number generator (define (random x) x) ;; Use low-level wasm hashq tables to avoid a cycle with (hoot ;; hashtables). (define (make-eq-hashtable) (%inline-wasm '(func (result (ref eq)) (call $make-hash-table)))) (define (hashtable-ref table key) (%inline-wasm '(func (param $table (ref eq)) (param $key (ref eq)) (result (ref eq)) (call $hashq-ref (ref.cast $hash-table (local.get $table)) (local.get $key) (ref.i31 (i32.const 1)))) table key)) (define (hashtable-set! table key value) (%inline-wasm '(func (param $table (ref eq)) (param $key (ref eq)) (param $value (ref eq)) (call $hashq-set! (ref.cast $hash-table (local.get $table)) (local.get $key) (local.get $value))) table key value)) (define (record-type-compare vtable) (%struct-ref vtable 7)) (define (bytevector=? x y) (let ((n (bytevector-length x))) (and (= n (bytevector-length y)) (let lp ((i 0)) (or (= i n) (and (eqv? (bytevector-u8-ref x i) (bytevector-u8-ref y i)) (lp (+ i 1)))))))) (define (bitvector=? x y) (let ((n (bitvector-length x))) (and (= n (bitvector-length y)) (let lp ((i 0)) (or (= i n) (and (eqv? (bitvector-ref x i) (bitvector-ref y i)) (lp (+ i 1)))))))) ;; Bounds for precheck and fast/slow interleave paths. These ;; magic numbers are taken straight out of the aforementioned ;; paper. (define k0 400) (define kb -40) ;; The precheck does a simple tree equality test with a bound on ;; the number of checks, recurring up to k times. This means that ;; the precheck will terminate even when given cyclic inputs. (define (pre? x y k) (cond ((eq? x y) k) ((pair? x) (and (pair? y) (if (<= k 0) k (let ((k (pre? (car x) (car y) (- k 1)))) (and k (pre? (cdr x) (cdr y) k)))))) ((vector? x) (and (vector? y) (let ((n (vector-length x))) (and (= n (vector-length y)) (let lp ((i 0) (k k)) (if (or (= i n) (<= k 0)) k (let ((k (pre? (vector-ref x i) (vector-ref y i) (- k 1)))) (and k (lp (+ i 1) k))))))))) ((record? x) (and (record? y) (let ((vtable (%struct-vtable x))) (and (eq? vtable (%struct-vtable y)) (match (record-type-compare vtable) (#f #f) (compare ;; Since the record type comparison procedure ;; is external to 'equal?', we need to create a ;; wrapper that updates the counter after each ;; call. Opaque records will never call ;; 'equal?*', so 'k*' is lazily initialized to ;; detect this case. (let ((k* #f)) (define (equal?* x y) (unless k* (set! k* k)) (and (> k* 0) (match (pre? x y k*) (#f (set! k* #f) #f) (k (set! k* (- k 1)) ;; The values were equal, but if ;; the precheck has reached its ;; bound we will lie and say the ;; values were not equal so ;; 'compare' will stop. (> k 0))))) (compare x y equal?*) k*))))) k)) ((string? x) (and (string? y) (string=? x y) k)) ((bytevector? x) (and (bytevector? y) (bytevector=? x y) k)) ((bitvector? x) (and (bitvector? y) (bitvector=? x y) k)) (else (and (eqv? x y) k)))) (define (interleave? ht x y k) ;; Union-find algorithm with splitting path compression. (define (union-find x y) (define (find b) (let ((n (box-ref b))) (if (number? n) b ;; Equivalence classes form chains of boxes. To ;; reduce pointer chasing as the set grows, the path ;; is compressed during lookup via the "splitting" ;; technique. Each box in the chain becomes linked to ;; the one two beyond it. (let loop ((b b) (n n)) (let ((nn (box-ref n))) (if (number? nn) n (begin (box-set! b nn) (loop n nn)))))))) (let ((bx (hashtable-ref ht x)) (by (hashtable-ref ht y))) (if (not bx) (if (not by) ;; Neither value has been visited before. Create a ;; new equivalence class for them to share. (let ((b (make-box 1))) (hashtable-set! ht x b) (hashtable-set! ht y b) #f) ;; x hasn't been visited before, but y has. Use y's ;; equivalence class. (let ((ry (find by))) (hashtable-set! ht x ry) #f)) (if (not by) ;; y hasn't been visited before, but x has. Use x's ;; equivalence class. (let ((rx (find bx))) (hashtable-set! ht y rx) #f) ;; Both x and y have been visited before. (let ((rx (find bx)) (ry (find by))) ;; If x and y share an equivalance class then they ;; are equal and we're done. Otherwise, the ;; representative of the smaller class is linked ;; to the representative of the larger class and ;; the size is updated to reflect the size of the ;; new class. (or (eq? rx ry) (let ((nx (box-ref rx)) (ny (box-ref ry))) (if (> nx ny) (begin (box-set! ry rx) (box-set! rx (+ nx ny)) #f) (begin (box-set! rx ry) (box-set! ry (+ ny nx)) #f))))))))) (define (e? x y k) (if (<= k 0) (if (= k kb) ;; The fast path is taken when k hits the lower bound, ;; resetting k in the process. The random k value ;; "reduces the likelihood of repeatedly tripping on ;; worst-case behavior in cases where sizes of the ;; input graphs happen to be related to the chosen ;; bounds in a bad way." (fast? x y (random (* 2 k0))) (slow? x y k)) (fast? x y k))) (define (slow? x y k) (cond ((eq? x y) k) ((pair? x) (and (pair? y) (if (union-find x y) ;; Reset k back to zero to re-enter slow? on the ;; basis that if one equivalence is found then it ;; is likely that more will be found. 0 (let ((k (e? (car x) (car y) (- k 1)))) (and k (e? (cdr x) (cdr y) k)))))) ((vector? x) (and (vector? y) (let ((length (vector-length x))) (and (= length (vector-length y)) (if (union-find x y) 0 (let lp ((i 0) (k (- k 1))) (if (= i length) k (let ((k (e? (vector-ref x i) (vector-ref y i) k))) (and k (lp (+ i 1) k)))))))))) ((record? x) (and (record? y) (let ((vtable (%struct-vtable x))) (and (eq? vtable (%struct-vtable y)) (match (record-type-compare vtable) (#f #f) (compare (let ((k* #f)) (define (equal?* x y) (unless k* (set! k* k)) (if (union-find x y) (begin (set! k* 0) #t) (match (e? x y k*) (#f (set! k* #f) #f) (k (set! k* (- k 1)) (> k 0))))) k*))))))) ((string? x) (and (string? y) (string=? x y) k)) ((bytevector? x) (and (bytevector? y) (bytevector=? x y) k)) ((bitvector? x) (and (bitvector? y) (bitvector=? x y) k)) (else (and (eqv? x y) k)))) (define (fast? x y k) (let ((k (- k 1))) (cond ((eq? x y) k) ((pair? x) (and (pair? y) (let ((k (e? (car x) (car y) k))) (and k (e? (cdr x) (cdr y) k))))) ((vector? x) (and (vector? y) (let ((length (vector-length x))) (and (= length (vector-length y)) (let lp ((i 0) (k k)) (if (= i length) k (let ((k (e? (vector-ref x i) (vector-ref y i) k))) (and k (lp (+ i 1) k))))))))) ((record? x) (and (record? y) (let ((vtable (%struct-vtable x))) (and (eq? vtable (%struct-vtable y)) (match (record-type-compare vtable) (#f #f) (compare (let ((k* #f)) (define (equal?* x y) (unless k* (set! k* k)) (match (e? x y k*) (#f (set! k* #f) #f) (k (set! k* (- k 1)) (> k 0)))) (and (compare x y equal?*) k)))))))) ((string? x) (and (string? y) (string=? x y) k)) ((bytevector? x) (and (bytevector? y) (bytevector=? x y) k)) ((bitvector? x) (and (bitvector? y) (bitvector=? x y) k)) (else (and (eqv? x y) k))))) (and (e? x y k) #t)) ;; Perform the precheck before falling back to the slower ;; interleave method. For atoms and small trees, the precheck ;; will be sufficient to determine equality. (let ((k (pre? x y k0))) ;; The precheck returns #f if not equal, a number greater than ;; zero if equal, or 0 if it couldn't determine equality within ;; k0 checks. For the first two cases, we can return ;; immediately. For the last case, we proceed to the ;; interleaved algorithm. (and k (or (> k 0) (interleave? (make-eq-hashtable) x y 0)))))) guile-hoot-0.7.0/lib/hoot/error-handling.scm000066400000000000000000000325141507574675700207640ustar00rootroot00000000000000;;; Catching errors. ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; with-exception-handler, guard, and all that. ;;; ;;; Code: (library (hoot error-handling) (export guard format-exception capture-stack stack-height print-backtrace) (import (hoot cond-expand) (hoot pairs) (hoot eq) (hoot errors) (hoot exceptions) (hoot fluids) (hoot inline-wasm) (only (hoot control) make-prompt-tag call-with-prompt abort-to-prompt) (hoot match) (hoot not) (hoot numbers) (hoot ports) (hoot procedures) (hoot records) (hoot strings) (hoot syntax) (hoot values) (hoot vectors) (hoot write)) ;; Snarfed from Guile's (ice-9 exceptions). Deviates a bit from R7RS. (define-syntax guard (lambda (stx) (define (dispatch tag exn clauses) (define (build-clause test handler clauses) #`(let ((t #,test)) (if t (abort-to-prompt #,tag #,handler t) #,(dispatch tag exn clauses)))) (syntax-case clauses (=> else) (() #`(raise-continuable #,exn)) (((test => f) . clauses) (build-clause #'test #'(lambda (res) (f res)) #'clauses)) (((else e e* ...) . clauses) (build-clause #'#t #'(lambda (res) e e* ...) #'clauses)) (((test) . clauses) (build-clause #'test #'(lambda (res) res) #'clauses)) (((test e* ...) . clauses) (build-clause #'test #'(lambda (res) e* ...) #'clauses)))) (syntax-case stx () ((guard (exn clause clause* ...) body body* ...) (identifier? #'exn) #`(let ((tag (make-prompt-tag))) (call-with-prompt tag (lambda () (with-exception-handler (lambda (exn) #,(dispatch #'tag #'exn #'(clause clause* ...))) (lambda () body body* ...))) (lambda (_ h v) (h v)))))))) (define (format-exception exception port) (display "Scheme error:\n") (match (simple-exceptions exception) (() (display "Empty exception object" port)) (components (let loop ((i 1) (components components)) (define (format-numbered-exception exception) (display " " port) (display i port) (display ". " port) (write exception port)) (match components ((component) (format-numbered-exception component)) ((component . rest) (format-numbered-exception component) (newline port) (loop (+ i 1) rest))))))) ;; A macro so as to avoid adding any stack frames. (define-syntax-rule (stack-height) (cond-expand (guile-vm (raise (make-unimplemented-error 'stack-height))) (hoot (%inline-wasm '(func (result (ref eq)) (call $i32->scm (global.get $ret-sp))))))) (define (capture-stack height) (cond-expand (guile-vm (raise (make-unimplemented-error 'capture-stack))) (hoot (define (stack-ref n) (%inline-wasm '(func (param $n i32) (result (ref eq)) (struct.new $code-ref (i32.const 0) (ref.as_non_null (table.get $ret-stack (local.get $n))))) n)) (define stack (make-vector (min height (stack-height)) #f)) (let lp ((i 0)) (when (< i (vector-length stack)) (vector-set! stack i (stack-ref i)) (lp (1+ i)))) stack))) (define* (print-backtrace stack origin file line column port #:optional (end (vector-length stack))) (cond-expand (guile-vm (raise (make-unimplemented-error 'print-backtrace))) (hoot (define (code-source code) (%inline-wasm '(func (param $code (ref func)) (result (ref eq) (ref eq) (ref eq)) (local $maybe-string (ref null string)) (local $i1 i32) (local $i2 i32) (call $code-source (local.get $code)) (local.set $i2) (local.set $i1) (local.set $maybe-string) (if (ref eq) (ref.is_null (local.get $maybe-string)) (then (ref.i31 (i32.const 1))) (else (struct.new $string (i32.const 0) (ref.as_non_null (local.get $maybe-string))))) (call $i32->scm (local.get $i1)) (call $i32->scm (local.get $i2))) code)) (define (code-name code) (%inline-wasm '(func (param $code (ref func)) (result (ref eq)) (local $maybe-string (ref null string)) (call $code-name (local.get $code)) (local.set $maybe-string) (if (ref eq) (ref.is_null (local.get $maybe-string)) (then (ref.i31 (i32.const 1))) (else (struct.new $string (i32.const 0) (ref.as_non_null (local.get $maybe-string)))))) code)) (define (print-file file) (match file (#f (write-string "In unknown file:\n" port)) (file (write-string "In " port) (write-string file port) (write-string ":\n" port))) (flush-output-port port)) (define (print-frame line col idx proc-name) (define (left-pad str size) (if (< (string-length str) size) (string-append (make-string (- size (string-length str)) #\space) str) str)) (define (right-pad str size) (if (< (string-length str) size) (string-append str (make-string (- size (string-length str)) #\space)) str)) (cond ((and line col) (write-string (string-append (left-pad (number->string line) 6) ":" (right-pad (number->string col) 3) " ") port)) (else (write-string " " port))) (write-string (left-pad (number->string idx) 3) port) (write-string " (" port) (write (or proc-name "_") port) (write-string " ā€¦)" port) (newline port) (flush-output-port port)) (write-string "Hoot backtrace:\n" port) (define (same-files? a b) (if a (and b (string=? a b)) (not b))) (let lp ((i 0) (previous-file #f)) (cond ((< i (vector-length stack)) (call-with-values (lambda () (code-source (vector-ref stack i))) (lambda (file line col) (define name (code-name (vector-ref stack i))) (unless (and (not (zero? i)) (same-files? file previous-file)) (print-file file)) (if (zero? line) (print-frame #f #f (- (vector-length stack) i) name) (print-frame line col (- (vector-length stack) i) name)) (lp (1+ i) file)))) (else (unless (same-files? file previous-file) (print-file file)) (print-frame line column 0 origin))))))) (cond-expand (guile-vm) (hoot-main (let () (define %exception-handler (make-fluid #f)) (define (fluid-ref* fluid depth) (%inline-wasm '(func (param $fluid (ref $fluid)) (param $depth i32) (result (ref eq)) (call $fluid-ref* (local.get $fluid) (local.get $depth))) fluid depth)) (define* (with-exception-handler handler thunk #:key (unwind? #f) (unwind-for-type #t)) (check-type handler procedure? 'with-exception-handler) (cond (unwind? (let ((tag (make-prompt-tag "exception handler"))) (call-with-prompt tag (lambda () (with-fluids ((%exception-handler (cons unwind-for-type tag))) (thunk))) (lambda (k exn) (handler exn))))) (else (let ((running? (make-fluid #f))) (with-fluids ((%exception-handler (cons running? handler))) (thunk)))))) (define (raise-non-continuable-exception) (raise (make-exception (make-non-continuable-violation) (make-exception-with-message "unhandled non-continuable exception")))) (define (fallback-exception-handler exn captured-height) (define stack (capture-stack captured-height)) (define port (current-error-port)) (define origin (and (exception-with-origin? exn) (exception-origin exn))) (call-with-values (lambda () (if (exception-with-source? exn) (values (exception-source-file exn) (exception-source-line exn) (exception-source-column exn)) (values #f #f #f))) (lambda (file line column) (print-backtrace stack origin file line column port port) (write-string "\nUncaught exception:\n" port) (format-exception exn port) (newline port) (flush-output-port port) (%inline-wasm '(func (param $status i32) (call $quit (local.get $status)) (unreachable)) 1)))) (define* (raise-exception exn #:key continuable?) (define captured-stack-height (stack-height)) (define (is-a? x type) (let ((vtable (%inline-wasm '(func (param $x (ref $struct)) (result (ref eq)) (ref.as_non_null (struct.get $struct $vtable (local.get $x)))) x))) (or (eq? vtable type) (let ((parents (record-type-parents vtable))) (let lp ((i 0)) (and (< i (vector-length parents)) (or (eq? (vector-ref parents i) type) (lp (1+ i))))))))) (define (exception-has-type? exn type) (cond ((eq? type #t) #t) ((exception? exn) (or (is-a? exn type) (and (compound-exception? exn) (let lp ((simple (compound-exception-components exn))) (match simple (() #f) ((x . rest) (or (is-a? x type) (lp rest)))))))) (else #f))) (let lp ((depth 0)) ;; FIXME: fluid-ref* takes time proportional to depth, which ;; makes this loop quadratic. (match (fluid-ref* %exception-handler depth) (#f (fallback-exception-handler exn captured-stack-height)) (((? fluid? running?) . handler) (if (fluid-ref running?) (lp (1+ depth)) (with-fluids ((running? #t)) (cond (continuable? (handler exn)) (else (handler exn) (raise-non-continuable-exception)))))) ((type . prompt-tag) (cond ((exception-has-type? exn type) ;; Due to dynamic state saving and restoration, it is ;; possible that the prompt is not on the dynamic ;; stack. This causes abort-to-prompt to throw an ;; exception of its own. That exception would be ;; handled by aborting to the same prompt again, ;; resulting in an unbounded loop. (with-exception-handler (lambda (exn) (lp (1+ depth))) (lambda () (abort-to-prompt prompt-tag exn)) #:unwind? #t) (raise-non-continuable-exception)) (else (lp (1+ depth)))))))) (define-syntax-rule (initialize-globals (global type proc) ...) (%inline-wasm '(func (param global type) ... (global.set global (local.get global)) ...) proc ...)) (define-syntax-rule (initialize-proc-globals (global proc) ...) (initialize-globals (global (ref $proc) proc) ...)) (initialize-proc-globals ($with-exception-handler with-exception-handler) ($raise-exception raise-exception)))) (hoot-aux))) guile-hoot-0.7.0/lib/hoot/errors.scm000066400000000000000000000116111507574675700173600ustar00rootroot00000000000000;;; Error constructors ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Exception constructors for common errors. ;;; ;;; Code: (library (hoot errors) (export make-size-error make-index-error make-range-error make-start-offset-error make-end-offset-error make-type-error make-unimplemented-error make-assertion-error make-not-seekable-error make-runtime-error-with-message make-runtime-error-with-message+irritants make-match-error make-arity-error make-invalid-keyword-error make-unrecognized-keyword-error make-missing-keyword-argument-error make-syntax-violation raise raise-continuable raise-exception with-exception-handler error assert check-size check-index check-range check-type) (import (only (hoot primitives) %raise-exception %exact-integer? %< %<=) (hoot inline-wasm) (hoot syntax)) (define-syntax-rule (define-error-constructor (name arg ...) global) (define (name arg ...) ((%inline-wasm '(func (result (ref eq)) (global.get global))) arg ...))) (define-error-constructor (make-size-error val max who) $make-size-error) (define-error-constructor (make-index-error val size who) $make-index-error) (define-error-constructor (make-range-error val min max who) $make-range-error) (define-error-constructor (make-start-offset-error val size who) $make-start-offset-error) (define-error-constructor (make-end-offset-error val size who) $make-end-offset-error) (define-error-constructor (make-type-error val who what) $make-type-error) (define-error-constructor (make-unimplemented-error who) $make-unimplemented-error) (define-error-constructor (make-assertion-error expr who) $make-assertion-error) (define-error-constructor (make-not-seekable-error port who) $make-not-seekable-error) (define-error-constructor (make-runtime-error-with-message msg) $make-runtime-error-with-message) (define-error-constructor (make-runtime-error-with-message+irritants msg irritants) $make-runtime-error-with-message+irritants) (define-error-constructor (make-match-error v) $make-match-error) (define-error-constructor (make-arity-error v who) $make-arity-error) (define-error-constructor (make-invalid-keyword-error kw) $make-invalid-keyword-error) (define-error-constructor (make-unrecognized-keyword-error kw) $make-unrecognized-keyword-error) (define-error-constructor (make-missing-keyword-argument-error kw) $make-missing-keyword-argument-error) (define-error-constructor (make-syntax-violation who message form subform) $make-syntax-violation) (define (raise exn) (%raise-exception exn)) (define (raise-continuable exn) ((%inline-wasm '(func (result (ref eq)) (global.get $raise-exception))) exn #:continuable? #t)) (define raise-exception (case-lambda* ((exn) (%raise-exception exn)) ((exn #:key continuable?) (if continuable? (raise-continuable exn) (%raise-exception exn))))) (define* (with-exception-handler handler thunk #:key (unwind? #f) (unwind-for-type #t)) ((%inline-wasm '(func (result (ref eq)) (global.get $with-exception-handler))) handler thunk #:unwind? unwind? #:unwind-for-type unwind-for-type)) (define error (case-lambda ((msg) (raise (make-runtime-error-with-message msg))) ((msg . args) (raise (make-runtime-error-with-message+irritants msg args))))) (define-syntax-rule (assert expr who) (unless expr (raise (make-assertion-error 'expr who)))) (define-syntax-rule (check-size x max who) (unless (and (%exact-integer? x) (%<= 0 x) (%<= x max)) (raise (make-size-error x max who)))) (define-syntax-rule (check-index x size who) (unless (and (%exact-integer? x) (%<= 0 x) (%< x size)) (raise (make-index-error x size who)))) (define-syntax-rule (check-range x min max who) (unless (and (%exact-integer? x) (%<= min x) (%<= x max)) (raise (make-range-error x min max who)))) (define-syntax-rule (check-type x predicate who) (unless (predicate x) (raise (make-type-error x who 'predicate))))) guile-hoot-0.7.0/lib/hoot/eval.scm000066400000000000000000000022701507574675700167740ustar00rootroot00000000000000;;; Eval ;;; Copyright (C) 2024 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Eval. Derived from Andy Wingo's work on Guile's ice-9/eval.scm. ;;; ;;; Code: (library (hoot eval) (export eval) (import (hoot errors) (hoot expander) (hoot modules) (hoot primitive-eval) (hoot syntax) (hoot syntax-objects)) (define* (eval exp env) (check-type env module? 'eval) (primitive-eval (expand-syntax (if (syntax? exp) exp (datum->syntax #f exp)) env) env))) guile-hoot-0.7.0/lib/hoot/exceptions.scm000066400000000000000000000355711507574675700202400ustar00rootroot00000000000000;;; Exception definitions ;;; Copyright (C) 2024, 2025 Igalia, S.L. ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. ;;; Commentary: ;;; ;;; Exception constructors for common errors. ;;; ;;; Code: (library (hoot exceptions) (export &exception simple-exception? &compound-exception make-compound-exception compound-exception? compound-exception-components define-exception-type simple-exceptions make-exception exception? &message make-exception-with-message exception-with-message? exception-message &warning make-warning warning? &serious make-serious-exception serious-exception? &error make-error error? &external-error make-external-error external-error? &violation make-violation violation? &assertion make-assertion-violation assertion-violation? &arity-violation make-arity-violation arity-violation? &implementation-restriction make-implementation-restriction-violation implementation-restriction-violation? &failed-type-check make-failed-type-check failed-type-check? failed-type-check-predicate &non-continuable make-non-continuable-violation non-continuable-violation? &irritants make-exception-with-irritants exception-with-irritants? exception-irritants &origin make-exception-with-origin exception-with-origin? exception-origin &source make-exception-with-source exception-with-source? exception-source-file exception-source-line exception-source-column &lexical make-lexical-violation lexical-violation? &i/o make-i/o-error i/o-error? &i/o-line-and-column make-i/o-line-and-column-error i/o-line-and-column-error? i/o-error-line i/o-error-column &i/o-filename make-i/o-filename-error i/o-filename-error? i/o-error-filename &i/o-not-seekable make-i/o-not-seekable-error i/o-not-seekable-error? &i/o-port make-i/o-port-error i/o-port-error? i/o-error-port &syntax make-syntax-error syntax-error? &invalid-syntax make-invalid-syntax-error invalid-syntax-error? invalid-syntax-form invalid-syntax-subform) (import (hoot syntax) (hoot features) (hoot cond-expand) (hoot errors) (hoot eq) (hoot inline-wasm) (hoot pairs) (hoot procedures) (hoot lists) (hoot values) (hoot records) (hoot syntax-objects) (hoot match)) (define-record-type &exception #:extensible? #t (make-&exception) simple-exception?) (define-record-type &compound-exception (make-compound-exception components) compound-exception? (components compound-exception-components)) (define (simple-exceptions exception) "Return a list of the simple exceptions that compose the exception object @var{exception}." (cond ((compound-exception? exception) (compound-exception-components exception)) ((simple-exception? exception) (list exception)) (else (raise (make-type-error exception 'exception? 'simple-exceptions))))) (define (make-exception . exceptions) "Return an exception object composed of @var{exceptions}." (define (flatten exceptions) (if (null? exceptions) '() (append (simple-exceptions (car exceptions)) (flatten (cdr exceptions))))) (let ((simple (flatten exceptions))) (if (and (pair? simple) (null? (cdr simple))) (car simple) (make-compound-exception simple)))) (define (exception? obj) "Return true if @var{obj} is an exception object." (or (compound-exception? obj) (simple-exception? obj))) (define-syntax define-exception-type (lambda (stx) (define (parent-fields parent) (let-values (((kind value) (syntax-local-binding parent))) (datum->syntax parent (or (and (eq? kind 'macro) (procedure-property value 'record-type?) (procedure-property value 'fields)) '())))) (syntax-case stx () ((define-exception-type exn parent make-exn exn? (field exn-field) ...) (with-syntax (((pfield ...) (parent-fields #'parent)) ((%exn-field ...) (generate-temporaries #'(exn-field ...)))) #'(begin (define-record-type exn #:parent parent #:extensible? #t (make-exn pfield ... field ...) %exn? (field %exn-field) ...) (define (exn? x) (or (%exn? x) (and (compound-exception? x) (let lp ((simple (compound-exception-components x))) (match simple (() #f) ((x . simple) (or (%exn? x) (lp simple)))))))) (define (exn-field x) (if (%exn? x) (%exn-field x) (let lp ((simple (compound-exception-components x))) (match simple (() (raise (make-type-error x 'exn-field 'exn?))) ((x . simple) (if (%exn? x) (%exn-field x) (lp simple))))))) ...)))))) (define-exception-type &message &exception make-exception-with-message exception-with-message? (message exception-message)) (define-exception-type &warning &exception make-warning warning?) (define-exception-type &serious &exception make-serious-exception serious-exception?) (define-exception-type &error &serious make-error error?) (define-exception-type &external-error &error make-external-error external-error?) (define-exception-type &violation &serious make-violation violation?) (define-exception-type &assertion &violation make-assertion-violation assertion-violation?) (define-exception-type &arity-violation &violation make-arity-violation arity-violation?) (define-exception-type &implementation-restriction &violation make-implementation-restriction-violation implementation-restriction-violation?) (define-exception-type &failed-type-check &assertion make-failed-type-check failed-type-check? (predicate failed-type-check-predicate)) (define-exception-type &non-continuable &violation make-non-continuable-violation non-continuable-violation?) (define-exception-type &irritants &exception make-exception-with-irritants exception-with-irritants? (irritants exception-irritants)) (define-exception-type &origin &exception make-exception-with-origin exception-with-origin? (origin exception-origin)) (define-exception-type &source &exception make-exception-with-source exception-with-source? (file exception-source-file) (line exception-source-line) (column exception-source-column)) (define-exception-type &lexical &violation make-lexical-violation lexical-violation?) (define-exception-type &i/o &error make-i/o-error i/o-error?) (define-exception-type &i/o-line-and-column &i/o make-i/o-line-and-column-error i/o-line-and-column-error? (line i/o-error-line) (column i/o-error-column)) (define-exception-type &i/o-filename &i/o make-i/o-filename-error i/o-filename-error? (filename i/o-error-filename)) (define-exception-type &i/o-not-seekable &i/o make-i/o-not-seekable-error i/o-not-seekable-error?) (define-exception-type &i/o-port &i/o make-i/o-port-error i/o-port-error? (port i/o-error-port)) (define-exception-type &syntax &violation make-syntax-error syntax-error?) (define-exception-type &invalid-syntax &syntax make-invalid-syntax-error invalid-syntax-error? (form invalid-syntax-form) (subform invalid-syntax-subform)) (cond-expand (guile-vm) (hoot-main (let () (define (make-with-irritants exn message origin irritants) (make-exception exn (make-exception-with-message message) (make-exception-with-origin origin) (make-exception-with-irritants irritants))) (define-syntax-rule (define-exception-constructor (name arg ...) body ...) (cond-expand ((and) (define (name arg ...) body ...)) (else (define (name arg ...) (list arg ...))))) (define-exception-constructor (make-size-error val max who) (make-with-irritants (make-error) "size out of range" who (list val))) (define-exception-constructor (make-index-error val size who) (make-with-irritants (make-error) "index out of range" who (list val))) (define-exception-constructor (make-range-error val min max who) (make-with-irritants (make-error) "value out of range" who (list val))) (define-exception-constructor (make-start-offset-error val size who) (make-with-irritants (make-error) "start offset out of range" who (list val))) (define-exception-constructor (make-end-offset-error val size who) (make-with-irritants (make-error) "end offset out of range" who (list val))) (define-exception-constructor (make-type-error val who what) (make-with-irritants (make-failed-type-check what) "type check failed" who (list val))) (define-exception-constructor (make-unimplemented-error who) (make-exception (make-implementation-restriction-violation) (make-exception-with-message "unimplemented") (make-exception-with-origin who))) (define-exception-constructor (make-assertion-error expr who) (make-with-irritants (make-assertion-violation) "assertion failed" who (list expr))) (define-exception-constructor (make-not-seekable-error port who) (make-exception (make-i/o-not-seekable-error) (make-i/o-port-error port) (make-exception-with-origin who))) (define-exception-constructor (make-runtime-error-with-message msg) (make-exception (make-error) (make-exception-with-message msg))) (define-exception-constructor (make-runtime-error-with-message+irritants msg irritants) (make-exception (make-error) (make-exception-with-message msg) (make-exception-with-irritants irritants))) (define-exception-constructor (make-match-error v) (make-exception (make-assertion-violation) (make-exception-with-message "value failed to match") (make-exception-with-irritants (list v)))) (define-exception-constructor (make-arity-error v who) (define (annotate-with-origin exn) (if who (make-exception (make-exception-with-origin who) exn) exn)) (annotate-with-origin (make-exception (make-arity-violation) (make-exception-with-message "wrong number of arguments") (make-exception-with-irritants (list v))))) (define-exception-constructor (make-invalid-keyword-error kw) (make-exception (make-arity-violation) (make-exception-with-message "expected a keyword") (make-exception-with-irritants (list kw)))) (define-exception-constructor (make-unrecognized-keyword-error kw) (make-exception (make-arity-violation) (make-exception-with-message "unexpected keyword") (make-exception-with-irritants (list kw)))) (define-exception-constructor (make-missing-keyword-argument-error kw) (make-exception (make-arity-violation) (make-exception-with-message "keyword missing an argument") (make-exception-with-irritants (list kw)))) (define-exception-constructor (make-syntax-violation who message form subform) (make-exception (if form (make-invalid-syntax-error form subform) (make-syntax-error)) (make-exception-with-message message) (make-exception-with-origin who))) (define (annotate-with-source exn file line column) (if (exception? exn) (make-exception exn (make-exception-with-source file line column)) exn)) (define-syntax-rule (initialize-globals (global type proc) ...) (%inline-wasm '(func (param global type) ... (global.set global (local.get global)) ...) proc ...)) (define-syntax-rule (initialize-proc-globals (global proc) ...) (initialize-globals (global (ref $proc) proc) ...)) (initialize-proc-globals ($make-size-error make-size-error) ($make-index-error make-index-error) ($make-range-error make-range-error) ($make-start-offset-error make-start-offset-error) ($make-end-offset-error make-end-offset-error) ($make-type-error make-type-error) ($make-unimplemented-error make-unimplemented-error) ($make-assertion-error make-assertion-error) ($make-not-seekable-error make-not-seekable-error) ($make-runtime-error-with-message make-runtime-error-with-message) ($make-runtime-error-with-message+irritants make-runtime-error-with-message+irritants) ($make-match-error make-match-error) ($make-arity-error make-arity-error) ($make-invalid-keyword-error make-invalid-keyword-error) ($make-unrecognized-keyword-error make-unrecognized-keyword-error) ($make-missing-keyword-argument-error make-missing-keyword-argument-error) ($make-syntax-violation make-syntax-violation) ($annotate-with-source annotate-with-source)))) (else))) guile-hoot-0.7.0/lib/hoot/expander.scm000066400000000000000000004134121507574675700176570ustar00rootroot00000000000000;;; Syntax expander ;;; Copyright (C) 2024, 2025 Igalia, S.L. ;;; Copyright (C) 1997-1998,2000-2003,2005-2006,2008-2013,2015-2022,2024 ;;; Free Software Foundation, Inc. ;;; ;;; This library is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU Lesser General Public License as ;;; published by the Free Software Foundation, either version 3 of the ;;; License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Lesser General Public License for more details. ;;; ;;; You should have received a copy of the GNU Lesser General Public ;;; License along with this program. If not, see ;;; . ;;; Originally extracted from Chez Scheme Version 5.9f ;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman ;;; ;;; Copyright (c) 1992-1997 Cadence Research Systems ;;; Permission to copy this software, in whole or in part, to use this ;;; software for any lawful purpose, and to redistribute this software ;;; is granted subject to the restriction that all copies made of this ;;; software must include this copyright notice in full. This software ;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED, ;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY ;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY ;;; NATURE WHATSOEVER. ;;; ;;; This code is based on "Syntax Abstraction in Scheme" ;;; by R. Kent Dybvig, Robert Hieb, and Carl Bruggeman. ;;; Lisp and Symbolic Computation 5:4, 295-326, 1992. ;;; ;;; Commentary: ;;; This file defines Hoot's syntax expander and a set of associated ;;; syntactic forms and procedures. For more documentation, see The ;;; Scheme Programming Language, Fourth Edition (R. Kent Dybvig, MIT ;;; Press, 2009), or the R6RS. ;;; Code: (library (hoot expander) (export (rename (macroexpand expand-syntax)) initialize-core-syntax!) (import (hoot apply) (hoot assoc) (hoot core-syntax) (only (hoot core-syntax-helpers) %initialize-syntax-helpers!) (hoot cross-compilation) (hoot debug) (hoot eq) (hoot equal) (hoot errors) (hoot primitive-eval) (hoot gensym) (hoot hashtables) (hoot keywords) (hoot lists) (hoot modules) (hoot not) (only (hoot numbers) 1+ 1- = zero? most-positive-fixnum) (hoot pairs) (hoot parameters) (hoot procedures) (hoot records) (hoot strings) (hoot symbols) (rename (hoot syntax-objects) (syntax-module %syntax-module)) (hoot syntax-transformers) (hoot tree-il) (hoot values) (hoot vectors) (only (hoot write) number->string) (only (guile) and-map or-map string-join string-concatenate object->string) (ice-9 match)) (define expansion-environment (make-parameter #f)) (define (syntax-module stx) (let ((mod (%syntax-module stx))) (match mod (#f #f) (('private . _) ;; Unlike Guile's psyntax, where R6RS modules are implemented by ;; macros and @@, and which has to deal with module system boot, in ;; Hoot we just have one kind of top-level reference: with respect ;; to a specific module, from the inside of that module. This ;; corresponds with "private" from upstream psyntax, which is the ;; same as "hygiene" but without recapturing current-module within a ;; top-level sequence. We don't have "bare", "public", or ;; "primitive". mod) (('hygiene . tail) ;; However, for references that were residualized by Guile's ;; expander, we may have "hygiene" references embedded in ;; syntax objects. These are of two kinds: namespaced, for a ;; library-group expansion, or bare, if for some reason a ;; module was expanded on its own. Probably the latter ;; shouldn't happen. Anyway, strip off the namespace, if ;; present, so that those free variables resolve within the ;; module tree that was passed in as a value. (match tail (('% namespace . name) (cons 'private name)) (name (cons 'private name))))))) (define (resolve-module* mod) (match mod (('private . modname) (resolve-module (expansion-environment) modname)))) (define (resolve-variable mod var kt kf) (match (resolve-module* mod) (#f (kf)) (mod (module-variable mod var #:private? #t #:found kt #:not-found kf)))) (define (top-level-eval x mod) (primitive-eval x (or (resolve-module* mod) (syntax-violation #f "no module found" mod)))) (define (local-eval x mod) (top-level-eval x mod)) (define (install-syntax-definition! module type sym val) (module-define! module sym (make-syntax-transformer type val) #:allow-redefinition? #t)) (define (maybe-name-value name val) (if (lambda? val) (let ((meta (lambda-meta val))) (if (assq 'name meta) val (make-lambda (tree-il-src val) (acons 'name name meta) (lambda-body val)))) val)) ;; output constructors (define build-void make-void) (define build-call make-call) (define build-conditional make-conditional) (define build-lexical-reference make-lexical-ref) (define (build-lexical-assignment sourcev name var exp) (make-lexical-set sourcev name var (maybe-name-value name exp))) (define (analyze-variable mod var modref-cont) (match mod (('private . mod) (modref-cont mod var #f)))) (define (build-global-reference src var mod) (analyze-variable mod var (lambda (mod var public?) (make-module-ref src mod var public?)))) (define (build-global-assignment src var exp mod) (let ((exp (maybe-name-value var exp))) (analyze-variable mod var (lambda (mod var public?) (make-module-set src mod var public? exp))))) (define (build-global-definition src mod var exp) (make-toplevel-define src (and mod (cdr mod)) var (maybe-name-value var exp))) (define (build-simple-lambda src req rest vars meta exp) (make-lambda src meta (make-lambda-case ;; src req opt rest kw inits vars body else src req #f rest #f '() vars exp #f))) (define build-case-lambda make-lambda) (define build-lambda-case make-lambda-case) (define build-primcall make-primcall) (define build-primref make-primitive-ref) (define build-data make-const) (define (build-sequence src exps) (match exps ((tail) tail) ((head . tail) (make-seq src head (build-sequence #f tail))))) (define (build-let src ids vars val-exps body-exp) (match (map maybe-name-value ids val-exps) (() body-exp) (val-exps (make-let src ids vars val-exps body-exp)))) (define (build-named-let src ids vars val-exps body-exp) (match vars ((f . vars) (match ids ((f-name . ids) (let ((proc (build-simple-lambda src ids #f vars '() body-exp))) (make-letrec src #f (list f-name) (list f) (list (maybe-name-value f-name proc)) (build-call src (build-lexical-reference src f-name f) (map maybe-name-value ids val-exps))))))))) (define (build-letrec src in-order? ids vars val-exps body-exp) (match (map maybe-name-value ids val-exps) (() body-exp) (val-exps (make-letrec src in-order? ids vars val-exps body-exp)))) (define (gen-lexical id) ;; Generate a unique symbol for a lexical variable. These need to ;; be symbols as they are embedded in Tree-IL. In future these ;; should be more globally unique, as in Guile. (gensym (symbol->string id))) (define no-source #f) (define (source-annotation x) (and (syntax? x) (syntax-sourcev x))) (define-syntax-rule (arg-check pred? e who) (let ((x e)) (unless (pred? x) (syntax-violation who "invalid argument" x)))) ;; compile-time environments ;; wrap and environment comprise two level mapping. ;; wrap : id --> label ;; env : label --> ;; environments are represented in two parts: a lexical part and a ;; global part. The lexical part is a simple list of associations ;; from labels to bindings. The global part is implemented by (hoot ;; module)'s registry of module environments and associates symbols ;; with bindings. ;; global (assumed global variable) and displaced-lexical (see below) ;; do not show up in any environment; instead, they are fabricated by ;; resolve-identifier when it finds no other bindings. ;; ::= ((