pax_global_header00006660000000000000000000000064151453460760014525gustar00rootroot0000000000000052 comment=0fea20c82182fe661f75b00a8889d801fe2d79b6 janet-1.41.2/000077500000000000000000000000001514534607600127135ustar00rootroot00000000000000janet-1.41.2/.builds/000077500000000000000000000000001514534607600142535ustar00rootroot00000000000000janet-1.41.2/.builds/freebsd.yml000066400000000000000000000002731514534607600164120ustar00rootroot00000000000000image: freebsd/14.x sources: - https://git.sr.ht/~bakpakin/janet packages: - gmake tasks: - build: | cd janet gmake gmake test sudo gmake install sudo gmake uninstall janet-1.41.2/.builds/linux.yml000066400000000000000000000013101514534607600161300ustar00rootroot00000000000000image: archlinux sources: - https://git.sr.ht/~bakpakin/janet packages: - meson tasks: - with-epoll: | cd janet meson setup with-epoll --buildtype=release cd with-epoll meson configure -Depoll=true ninja ninja test - no-epoll: | cd janet meson setup no-epoll --buildtype=release cd no-epoll meson configure -Depoll=false ninja ninja test sudo ninja install - meson_min: | cd janet meson setup build_meson_min --buildtype=release -Dsingle_threaded=true -Dnanbox=false -Ddynamic_modules=false -Ddocstrings=false -Dnet=false -Dsourcemaps=false -Dpeg=false -Dassembler=false -Dint_types=false -Dreduced_os=true -Dffi=false cd build_meson_min ninja janet-1.41.2/.builds/openbsd.yml000066400000000000000000000016561514534607600164400ustar00rootroot00000000000000image: openbsd/7.7 sources: - https://git.sr.ht/~bakpakin/janet packages: - gmake - meson tasks: - gmake: | cd janet gmake gmake test doas gmake install doas gmake uninstall - meson_min: | cd janet meson setup build_meson_min --buildtype=release -Dsingle_threaded=true -Dnanbox=false -Ddynamic_modules=false -Ddocstrings=false -Dnet=false -Dsourcemaps=false -Dpeg=false -Dassembler=false -Dint_types=false -Dreduced_os=true -Dffi=false cd build_meson_min ninja - meson_reduced: | cd janet meson setup build_meson_reduced --buildtype=release -Dreduced_os=true cd build_meson_reduced ninja - meson_prf: | cd janet meson setup build_meson_prf --buildtype=release -Dprf=true cd build_meson_prf ninja ninja test - meson_default: | cd janet meson setup build_meson_default --buildtype=release cd build_meson_default ninja ninja test doas ninja install janet-1.41.2/.gitattributes000066400000000000000000000002561514534607600156110ustar00rootroot00000000000000*.janet linguist-language=Janet *.janet text eol=lf *.c text eol=lf *.h text eol=lf *.md text eol=lf *.yml text eol=lf *.build text eol=lf *.txt text eol=lf *.sh text eol=lf janet-1.41.2/.github/000077500000000000000000000000001514534607600142535ustar00rootroot00000000000000janet-1.41.2/.github/cosmo/000077500000000000000000000000001514534607600153735ustar00rootroot00000000000000janet-1.41.2/.github/cosmo/build000066400000000000000000000021601514534607600164140ustar00rootroot00000000000000#!/bin/sh set -eux COSMO_DIR="/sc/cosmocc" # build x86_64 X86_64_CC="/sc/cosmocc/bin/x86_64-unknown-cosmo-cc" X86_64_AR="/sc/cosmocc/bin/x86_64-unknown-cosmo-ar" mkdir -p /sc/cosmocc/x86_64 make -j CC="$X86_64_CC" AR="$X86_64_AR" HAS_SHARED=0 JANET_NO_AMALG=1 cp build/janet /sc/cosmocc/x86_64/janet make clean # build aarch64 AARCH64_CC="/sc/cosmocc/bin/aarch64-unknown-cosmo-cc" AARCH64_AR="/sc/cosmocc/bin/aarch64-unknown-cosmo-ar" mkdir -p /sc/cosmocc/aarch64 make -j CC="$AARCH64_CC" AR="$AARCH64_AR" HAS_SHARED=0 JANET_NO_AMALG=1 cp build/janet /sc/cosmocc/aarch64/janet make clean # fat binary apefat () { OUTPUT="$1" OLDNAME_X86_64="$(basename -- "$2")" OLDNAME_AARCH64="$(basename -- "$3")" TARG_FOLD="$(dirname "$OUTPUT")" "$COSMO_DIR/bin/apelink" -l "$COSMO_DIR/bin/ape-x86_64.elf" \ -l "$COSMO_DIR/bin/ape-aarch64.elf" \ -M "$COSMO_DIR/bin/ape-m1.c" \ -o "$OUTPUT" \ "$2" \ "$3" cp "$2" "$TARG_FOLD/$OLDNAME_X86_64.x86_64" cp "$3" "$TARG_FOLD/$OLDNAME_AARCH64.aarch64" } apefat /sc/cosmocc/janet.com /sc/cosmocc/x86_64/janet /sc/cosmocc/aarch64/janet janet-1.41.2/.github/cosmo/setup000066400000000000000000000010341514534607600164540ustar00rootroot00000000000000#!/bin/sh set -e sudo apt-get update sudo apt-get install -y ca-certificates libssl-dev\ qemu-utils qemu-user-static\ texinfo groff\ cmake ninja-build bison zip\ pkg-config build-essential autoconf re2c # download cosmocc cd /sc wget https://github.com/jart/cosmopolitan/releases/download/4.0.2/cosmocc-4.0.2.zip mkdir -p cosmocc cd cosmocc unzip ../cosmocc-4.0.2.zip # register cd /sc/cosmocc sudo cp ./bin/ape-x86_64.elf /usr/bin/ape sudo sh -c "echo ':APE:M::MZqFpD::/usr/bin/ape:' >/proc/sys/fs/binfmt_misc/register" janet-1.41.2/.github/workflows/000077500000000000000000000000001514534607600163105ustar00rootroot00000000000000janet-1.41.2/.github/workflows/codeql.yml000066400000000000000000000015311514534607600203020ustar00rootroot00000000000000name: "CodeQL" on: push: branches: [ "master" ] pull_request: branches: [ "master" ] schedule: - cron: "2 7 * * 4" jobs: analyze: name: Analyze runs-on: ubuntu-latest permissions: actions: read contents: read security-events: write strategy: fail-fast: false matrix: language: [ cpp ] steps: - name: Checkout uses: actions/checkout@v3 - name: Initialize CodeQL uses: github/codeql-action/init@v3 with: languages: ${{ matrix.language }} queries: +security-and-quality tools: linked - name: Autobuild uses: github/codeql-action/autobuild@v3 - name: Perform CodeQL Analysis uses: github/codeql-action/analyze@v3 with: category: "/language:${{ matrix.language }}" janet-1.41.2/.github/workflows/release.yml000066400000000000000000000070461514534607600204620ustar00rootroot00000000000000name: Release on: push: tags: - "v*.*.*" permissions: contents: read jobs: release: permissions: contents: write # for softprops/action-gh-release to create GitHub release name: Build release binaries runs-on: ${{ matrix.os }} strategy: matrix: os: [ ubuntu-latest ] steps: - name: Checkout the repository uses: actions/checkout@master - name: Set the version run: echo "version=${GITHUB_REF/refs\/tags\//}" >> $GITHUB_ENV - name: Set the platform run: echo "platform=$(tr '[A-Z]' '[a-z]' <<< $RUNNER_OS)" >> $GITHUB_ENV - name: Compile the project run: make clean && make - name: Build the artifact run: JANET_DIST_DIR=janet-${{ env.version }}-${{ env.platform }} make build/janet-${{ env.version }}-${{ env.platform }}-x64.tar.gz - name: Draft the release uses: softprops/action-gh-release@v1 with: draft: true files: | build/*.gz build/janet.h build/c/janet.c build/c/shell.c release-arm: permissions: contents: write # for softprops/action-gh-release to create GitHub release name: Build release binaries runs-on: ${{ matrix.os }} strategy: matrix: os: [ macos-latest ] steps: - name: Checkout the repository uses: actions/checkout@master - name: Set the version run: echo "version=${GITHUB_REF/refs\/tags\//}" >> $GITHUB_ENV - name: Set the platform run: echo "platform=$(tr '[A-Z]' '[a-z]' <<< $RUNNER_OS)" >> $GITHUB_ENV - name: Compile the project run: make clean && make - name: Build the artifact run: JANET_DIST_DIR=janet-${{ env.version }}-${{ env.platform }} make build/janet-${{ env.version }}-${{ env.platform }}-aarch64.tar.gz - name: Draft the release uses: softprops/action-gh-release@v1 with: draft: true files: | build/*.gz build/janet.h build/c/janet.c build/c/shell.c release-windows: permissions: contents: write # for softprops/action-gh-release to create GitHub release name: Build release binaries for windows runs-on: windows-latest steps: - name: Checkout the repository uses: actions/checkout@master - name: Setup MSVC uses: ilammy/msvc-dev-cmd@v1 - name: Build the project shell: cmd run: build_win all - name: Draft the release uses: softprops/action-gh-release@v1 with: draft: true files: | ./dist/*.zip ./*.zip ./*.msi release-cosmo: permissions: contents: write # for softprops/action-gh-release to create GitHub release name: Build release binaries for Cosmo runs-on: ubuntu-latest steps: - name: Checkout the repository uses: actions/checkout@master - name: create build folder run: | sudo mkdir -p /sc sudo chmod -R 0777 /sc - name: setup Cosmopolitan Libc run: bash ./.github/cosmo/setup - name: Set the version run: echo "version=${GITHUB_REF/refs\/tags\//}" >> $GITHUB_ENV - name: Set the platform run: echo "platform=cosmo" >> $GITHUB_ENV - name: build Janet APE binary run: bash ./.github/cosmo/build - name: push binary to github uses: softprops/action-gh-release@v1 with: draft: true files: | /sc/cosmocc/janet.com janet-1.41.2/.github/workflows/test.yml000066400000000000000000000114071514534607600200150ustar00rootroot00000000000000name: Test on: [push, pull_request] permissions: contents: read jobs: test-posix: name: Build and test on POSIX systems runs-on: ${{ matrix.os }} strategy: matrix: os: [ ubuntu-latest, macos-latest, macos-14 ] steps: - name: Checkout the repository uses: actions/checkout@master - name: Compile the project run: make clean && make - name: Test the project run: make test test-windows: name: Build and test on Windows strategy: matrix: os: [ windows-latest, windows-2022 ] runs-on: ${{ matrix.os }} steps: - name: Checkout the repository uses: actions/checkout@master - name: Setup MSVC uses: ilammy/msvc-dev-cmd@v1 - name: Build the project shell: cmd run: build_win - name: Test the project shell: cmd run: build_win test - name: Test installer build shell: cmd run: build_win dist test-windows-min: name: Build and test on Windows Minimal build strategy: matrix: os: [ windows-2022 ] runs-on: ${{ matrix.os }} steps: - name: Checkout the repository uses: actions/checkout@master - name: Setup MSVC uses: ilammy/msvc-dev-cmd@v1 - name: Setup Python uses: actions/setup-python@v2 with: python-version: '3.x' - name: Install Python Dependencies run: pip install meson ninja - name: Build shell: cmd run: | meson setup build_meson_min --buildtype=release -Dsingle_threaded=true -Dnanbox=false -Ddynamic_modules=false -Ddocstrings=false -Dnet=false -Dsourcemaps=false -Dpeg=false -Dassembler=false -Dint_types=false -Dreduced_os=true -Dffi=false cd build_meson_min ninja test-mingw: name: Build on Windows with Mingw runs-on: windows-latest defaults: run: shell: msys2 {0} strategy: matrix: msystem: [ UCRT64, CLANG64 ] steps: - name: Checkout the repository uses: actions/checkout@master - name: Setup Mingw uses: msys2/setup-msys2@v2 with: msystem: ${{ matrix.msystem }} update: true install: >- base-devel git gcc - name: Build shell: cmd run: make -j4 CC=gcc - name: Test shell: cmd run: make -j4 CC=gcc test test-mingw-linux: name: Build and test with Mingw on Linux + Wine runs-on: ubuntu-latest steps: - name: Checkout the repository uses: actions/checkout@master - name: Setup Mingw and wine run: | sudo dpkg --add-architecture i386 sudo apt-get update sudo apt-get install libstdc++6:i386 libgcc-s1:i386 sudo apt-get install gcc-mingw-w64-x86-64-win32 wine wine32 wine64 - name: Compile the project run: make clean && make CC=x86_64-w64-mingw32-gcc LD=x86_64-w64-mingw32-gcc UNAME=MINGW RUN=wine - name: Test the project run: make test UNAME=MINGW RUN=wine VERBOSE=1 test-arm-linux: name: Build and test ARM32 cross compilation runs-on: ubuntu-latest steps: - name: Checkout the repository uses: actions/checkout@master - name: Setup qemu and cross compiler run: | sudo apt-get update sudo apt-get install gcc-arm-linux-gnueabi qemu-user - name: Compile the project run: make RUN="qemu-arm -L /usr/arm-linux-gnueabi/" CC=arm-linux-gnueabi-gcc LD=arm-linux-gnueabi-gcc - name: Test the project run: make RUN="qemu-arm -L /usr/arm-linux-gnueabi/" SUBRUN="qemu-arm -L /usr/arm-linux-gnueabi/" test VERBOSE=1 test-s390x-linux: name: Build and test s390x in qemu runs-on: ubuntu-latest steps: - name: Checkout the repository uses: actions/checkout@master - name: Enable qemu run: docker run --privileged --rm tonistiigi/binfmt --install s390x - name: Build and run on emulated architecture run: docker run --rm -v .:/janet --platform linux/s390x alpine sh -c "apk update && apk add --no-interactive git build-base && cd /janet && make -j3 && make test" test-cosmo: name: Test build for Cosmo runs-on: ubuntu-latest steps: - name: Checkout the repository uses: actions/checkout@master - name: create build folder run: | sudo mkdir -p /sc sudo chmod -R 0777 /sc - name: setup Cosmopolitan Libc run: bash ./.github/cosmo/setup - name: Set the version run: echo "version=${GITHUB_REF/refs\/tags\//}" >> $GITHUB_ENV - name: Set the platform run: echo "platform=cosmo" >> $GITHUB_ENV - name: build Janet APE binary run: bash ./.github/cosmo/build janet-1.41.2/.gitignore000066400000000000000000000027631514534607600147130ustar00rootroot00000000000000# Target dst !*/**/dst janet !*/**/janet /build /builddir /Build /Release /Debug /Emscripten /src/include/generated/*.h janet-*.tar.gz dist /tmp # jpm lockfile lockfile.janet # Kakoune (fzf via fd) .fdignore # VSCode .vscode # Eclipse .project .cproject # Gnome Builder .buildconfig # Local directory for testing local # Common test files I use. temp.janet temp.c temp*janet temp*.c scratch.janet scratch.c # Emscripten *.bc janet.js janet.wasm # Generated files *.gen.h *.gen.c *.tmp temp.* # Generate test files *.out .orig # Tools xxd xxd.exe # VSCode .vs .clangd .cache # Swap files *.swp # Tags tags # Valgrind files vgcore.* *.out.* # WiX artifacts *.msi *.wixpdb # Makefile config /config.mk # Created by https://www.gitignore.io/api/c ### C ### # Prerequisites *.d # Object files *.o *.ko *.obj *.elf # Linker output *.ilk *.map *.exp # Precompiled Headers *.gch *.pch # Libraries *.lib *.a *.la *.lo # Shared objects (inc. Windows DLLs) *.dll *.so *.so.* *.dylib # Executables *.exe *.out *.app *.i*86 *.x86_64 *.hex # Debug files *.dSYM/ *.su *.idb *.pdb # GGov *.gcov # Kernel Module Compile Results *.mod* *.cmd modules.order Module.symvers Mkfile.old dkms.conf # Coverage files *.cov # End of https://www.gitignore.io/api/c # Created by https://www.gitignore.io/api/cmake ### CMake ### CMakeCache.txt CMakeFiles CMakeScripts Testing cmake_install.cmake install_manifest.txt compile_commands.json CTestTestfile.cmake # End of https://www.gitignore.io/api/cmake # Astyle *.orig janet-1.41.2/CHANGELOG.md000066400000000000000000001443321514534607600145330ustar00rootroot00000000000000# Changelog All notable changes to this project will be documented in this file. ## 1.41.2 - 2026-02-18 - Fix regressions in `put` for arrays and buffers. - Add `module/add-file-extension` - Add `module/add-syspath` - Fix issue with possible stack corrpution with abstract types that modify the current fiber. - Allow use of the interpreter and garbage collection inside module entry for native modules. ## 1.41.1 - 2026-02-15 - Revert to blocking behaior of `net/connect` on windows to fix spurious errors. - Allow overriding the loader when doing imports with the `:loader` argument. - Allow importing modules with a path extension to do what one would expect. - Add `find-all` argument to `module/find` - Add :threads, :unmarshal, :compiler, and :asm sandbox flags. - Add support for persistent REPL history with the environment variable `JANET_HISTFILE` - Fix a number of fuzzer-found compiler bugs - Fix windows processes launching bug with empty environment table that caused process-launch failures. - Add `:I`, `:V`, and `:N` flags to `os/open` for more control when creating streams. - Add `ev/go-gather` for a dynamic `ev/gather`. - Use color in script output if color is being used in REPL output. - Fix `varfn` macros handling of extra metadata. - Disallow certain degenerate uses of fibers with the ev/ module. - Add linting for unused bindings. - Add linting for extra or wrong parameters to &named functions. - Add `janet_optuinteger` and `janet_optuinteger64` to the C API. - Add `cms` combinator to PEGs. - Add `thaw-keep-keys` as a variant of thaw - The `repl` function now respects the `*repl-prompt*` dynamic binding by default. - Allow matching exact lengths of datastructures with the `match` macro using a dollar suffix. - Add initial support for Plan 9. Some modules (e.g. ev) are not yet enabled. - Allow specifying `:flycheck` for individual defines to annotate that they are safe to evaluate for flychecking. ## 1.40.1 - 2025-11-16 - Fix `JANET_REDUCED_OS` build regression caused by `os/posix-chroot`. - Code formatting ## 1.40.0 - 2025-11-15 - Add `os/posix-chroot` - Fix `ev/deadline` with interrupt race condition bug on Windows. - Improve `flycheck` by allowing functions and macros to define their own flycheck behavior via the metadata `:flycheck`. - Add `*flychecking*` dynamic binding to check if inside flycheck evalutation - Add `gcperthread` callback for abstract types. This lets threaded abstracts have a finalizer that is called per thread, as well as a global finalizer. - Add `JANET_DO_ERROR_*` flags to describe the return value of `janet_dobytes` and `janet_dostring`. ## 1.39.1 - 2025-08-30 - Add support for chdir in os/spawn on older macOS versions - Expose channels properly in C API ## 1.39.0 - 2025-08-24 - Various bug fixes - Add `net/socket` - Add support for illumos OS - Raise helpful errors for incorrect arguments to `import`. - Allow configuring `JANET_THREAD_LOCAL` during builds to allow multi-threading on unknown compilers. - Make `ffi/write` append to a buffer instead of insert at 0 by default. - Add `os/getpid` to get the current process id. - Add `:out` option to `os/spawn` to be able to redirect stderr to stdout with pipes. Add `interrupt?` argument to `ev/deadline` to use VM interruptions. ## 1.38.0 - 2025-03-18 - Add `bundle/replace` - Add CLI flags for the `bundle/` module to install and manage bundles. - Improve `?` peg special termination behavior - Add IEEE hex floats to grammar. - Add buffer peg literal support - Improve `split` peg special edge case behavior - Add Arm64 .msi support - Add `no-reuse` argument to `net/listen` to disable reusing server sockets - Add `struct/rawget` - Fix `deep=` and `deep-not=` to better handle degenerate cases with mutable table keys - Long strings will now dedent on `\r\n` instead of just `\n`. - Add `ev/to-file` for synchronous resource operations - Improve `file/open` error message by including path ## 1.37.1 - 2024-12-05 - Fix meson cross compilation - Update timeout documentation for networking APIs: timeouts raise errors and do not return nil. - Add `janet_addtimeout_nil(double sec);` to the C API. - Change string hashing. - Fix string equality bug. - Add `assertf` - Change how JANET_PROFILE is loaded to allow more easily customizing the environment. - Add `*repl-prompt*` dynamic binding to allow customizing the built in repl. - Add multiple path support in the `JANET_PATH` environment variables. This lets user more easily import modules from many directories. - Add `nth` and `only-tags` PEG specials to select from sub-captures while dropping the rest. ## 1.36.0 - 2024-09-07 - Improve error messages in `bundle/add*` functions. - Add CI testing and verify tests pass on the s390x architecture. - Save `:source-form` in environment entries when `*debug*` is set. - Add experimental `filewatch/` module for listening to file system changes on Linux and Windows. - Add `bundle/who-is` to query which bundle a file on disk was installed by. - Add `geomean` function - Add `:R` and `:W` flags to `os/pipe` to create blocking pipes on Posix and Windows systems. These streams cannot be directly read to and written from, but can be passed to subprocesses. - Add `array/join` - Add `tuple/join` - Add `bundle/add-bin` to make installing scripts easier. This also establishes a packaging convention for it. - Fix marshalling weak tables and weak arrays. - Fix bug in `ev/` module that could accidentally close sockets on accident. - Expose C functions for constructing weak tables in janet.h - Let range take non-integer values. ## 1.35.2 - 2024-06-16 - Fix some documentation typos. - Allow using `:only` in import without quoting. ## 1.35.0 - 2024-06-15 - Add `:only` argument to `import` to allow for easier control over imported bindings. - Add extra optional `env` argument to `eval` and `eval-string`. - Allow naming function literals with a keyword. This allows better stacktraces for macros without accidentally adding new bindings. - Add `bundle/` module for managing packages within Janet. This should replace the jpm packaging format eventually and is much simpler and amenable to more complicated builds. - Add macros `ev/with-lock`, `ev/with-rlock`, and `ev/with-wlock` for using mutexes and rwlocks. - Add `with-env` - Add *module-make-env* dynamic binding - Add buffer/format-at - Add long form command line options for readable CLI usage - Fix bug with `net/accept-loop` that would sometimes miss connections. ## 1.34.0 - 2024-03-22 - Add a new (split) PEG special by @ianthehenry - Add buffer/push-* sized int and float by @pnelson - Documentation improvements: @amano-kenji, @llmII, @MaxGyver83, @pepe, @sogaiu. - Expose _exit to skip certain cleanup with os/exit. - Swap set / body order for each by @sogaiu. - Abort on assert failure instead of exit. - Fix: os/proc-wait by @llmII. - Fix macex1 to keep syntax location for all tuples. - Restore if-let tail calls. - Don't try and resume fibers that can't be resumed. - Register stream on unmarshal. - Fix asm roundtrip issue. ## 1.33.0 - 2024-01-07 - Add more + and * keywords to default-peg-grammar by @sogaiu. - Use libc strlen in janet_buffer_push_cstring by @williewillus. - Be a bit safer with reference counting. - Add support for atomic loads in Janet's atomic abstraction. - Fix poll event loop CPU usage issue. - Add ipv6, shared, and cryptorand options to meson. - Add more ipv6 feature detection. - Fix loop for forever loop. - Cleaned up unused NetStateConnect, fixed janet_async_end() ev refcount by @zevv. - Fix warnings w/ MSVC and format. - Fix marshal_one_env w/ JANET_MARSHAL_UNSAFE. - Fix `(default)`. - Fix cannot marshal fiber with c stackframe, in a dynamic way that is fairly conservative. - Fix typo for SIGALARM in os/proc-kill. - Prevent bytecode optimization from remove mk* instructions. - Fix arity typo in peg.c by @pepe. - Update Makefile for MinGW. - Fix canceling waiting fiber. - Add a new (sub) PEG special by @ianthehenry. - Fix if net/server's handler has incorrect arity. - Fix macex raising on (). ## 1.32.1 - 2023-10-15 - Fix return value from C function `janet_dobytes` when called on Janet functions that yield to event loop. - Change C API for event loop interaction - get rid of JanetListener and instead use `janet_async_start` and `janet_async_end`. - Rework event loop to make fewer system calls on kqueue and epoll. - Expose atomic refcount abstraction in janet.h - Add `array/weak` for weak references in arrays - Add support for weak tables via `table/weak`, `table/weak-keys`, and `table/weak-values`. - Fix compiler bug with using the result of `(break x)` expression in some contexts. - Rework internal event loop code to be better behaved on Windows - Update meson build to work better on windows ## 1.31.0 - 2023-09-17 - Report line and column when using `janet_dobytes` - Add `:unless` loop modifier - Allow calling `reverse` on generators. - Improve performance of a number of core functions including `partition`, `mean`, `keys`, `values`, `pairs`, `interleave`. - Add `lengthable?` - Add `os/sigaction` - Change `every?` and `any?` to behave like the functional versions of the `and` and `or` macros. - Fix bug with garbage collecting threaded abstract types. - Add `:signal` to the `sandbox` function to allow intercepting signals. ## 1.30.0 - 2023-08-05 - Change indexing of `array/remove` to start from -1 at the end instead of -2. - Add new string escape sequences `\\a`, `\\b`, `\\?`, and `\\'`. - Fix bug with marshalling channels - Add `div` for floored division - Make `div` and `mod` variadic - Support `bnot` for integer types. - Define `(mod x 0)` as `x` - Add `ffi/pointer-cfunction` to convert pointers to cfunctions ## 1.29.1 - 2023-06-19 - Add support for passing booleans to PEGs for "always" and "never" matching. - Allow dictionary types for `take` and `drop` - Fix bug with closing channels while other fibers were waiting on them - `ev/take`, `ev/give`, and `ev/select` will now return the correct (documented) value when another fiber closes the channel. - Add `ffi/calling-conventions` to show all available calling conventions for FFI. - Add `net/setsockopt` - Add `signal` argument to `os/proc-kill` to send signals besides `SIGKILL` on Posix. - Add `source` argument to `os/clock` to get different time sources. - Various combinator functions now are variadic like `map` - Add `file/lines` to iterate over lines in a file lazily. - Reorganize test suite to be sorted by module rather than pseudo-randomly. - Add `*task-id*` - Add `env` argument to `fiber/new`. - Add `JANET_NO_AMALG` flag to Makefile to properly incremental builds - Optimize bytecode compiler to generate fewer instructions and improve loops. - Fix bug with `ev/gather` and hung fibers. - Add `os/isatty` - Add `has-key?` and `has-value?` - Make imperative arithmetic macros variadic - `ev/connect` now yields to the event loop instead of blocking while waiting for an ACK. ## 1.28.0 - 2023-05-13 - Various bug fixes - Make nested short-fn's behave a bit more predictably (it is still not recommended to nest short-fns). - Add `os/strftime` for date formatting. - Fix `ev/select` on threaded channels sometimes live-locking. - Support the `NO_COLOR` environment variable to turn off VT100 color codes in repl (and in scripts). See http://no-color.org/ - Disallow using `(splice x)` in contexts where it doesn't make sense rather than silently coercing to `x`. Instead, raise a compiler error. - Change the names of `:user8` and `:user9` signals to `:interrupt` and `:await` - Change the names of `:user8` and `:user9` fiber statuses to `:interrupted` and `:suspended`. - Add `ev/all-tasks` to see all currently suspended fibers. - Add `keep-syntax` and `keep-syntax!` functions to make writing macros easier. ## 1.27.0 - 2023-03-05 - Change semantics around bracket tuples to no longer be equal to regular tuples. - Add `index` argument to `ffi/write` for symmetry with `ffi/read`. - Add `buffer/push-at` - Add `ffi/pointer-buffer` to convert pointers to buffers the cannot be reallocated. This allows easier manipulation of FFI memory, memory mapped files, and buffer memory shared between threads. - Calling `ev/cancel` on a fiber waiting on `ev/gather` will correctly cancel the child fibers. - Add `(sandbox ...)` function to core for permission based security. Also add `janet_sandbox` to C API. The sandbox allows limiting access to the file system, network, ffi, and OS resources at runtime. - Add `(.locals)` function to debugger to see currently bound local symbols. - Track symbol -> slot mapping so debugger can get symbolic information. This exposes local bindings in `debug/stack` and `disasm`. - Add `os/compiler` to detect what host compiler was used to compile the interpreter - Add support for mingw and cygwin builds (mingw support also added in jpm). ## 1.26.0 - 2023-01-07 - Add `ffi/malloc` and `ffi/free`. Useful as tools of last resort. - Add `ffi/jitfn` to allow calling function pointers generated at runtime from machine code. Bring your own assembler, though. - Channels can now be marshalled. Pending state is not saved, only items in the channel. - Use the new `.length` function pointer on abstract types for lengths. Adding a `length` method will still work as well. - Support byte views on abstract types with the `.bytes` function pointer. - Add the `u` format specifier to printf family functions. - Allow printing 64 integer types in `printf` and `string/format` family functions. - Allow importing modules from custom directories more easily with the `@` prefix to module paths. For example, if there is a dynamic binding :custom-modules that is a file system path to a directory of modules, import from that directory with `(import @custom-modules/mymod)`. - Fix error message bug in FFI library. ## 1.25.1 - 2022-10-29 - Add `memcmp` function to core library. - Fix bug in `os/open` with `:rw` permissions not correct on Linux. - Support config.mk for more easily configuring the Makefile. ## 1.25.0 - 2022-10-10 - Windows FFI fixes. - Fix PEG `if-not` combinator with captures in the condition - Fix bug with `os/date` with nil first argument - Fix bug with `net/accept` on Linux that could leak file descriptors to subprocesses - Reduce number of hash collisions from pointer hashing - Add optional parameter to `marshal` to skip cycle checking code ## 1.24.1 - 2022-08-24 - Fix FFI bug on Linux/Posix - Improve parse error messages for bad delimiters. - Add optional `name` parameter to the `short-fn` macro. ## 1.24.0 - 2022-08-14 - Add FFI support to 64-bit windows compiled with MSVC - Don't process shared object names passed to dlopen. - Add better support for windows console in the default shell.c for auto-completion and other shell-like input features. - Improve default error message from `assert`. - Add the `tabseq` macro for simpler table comprehensions. - Allow setting `(dyn :task-id)` in fibers to improve context in supervisor messages. Prior to this change, supervisor messages over threaded channels would be from ambiguous threads/fibers. ## 1.23.0 - 2022-06-20 - Add experimental `ffi/` module for interfacing with dynamic libraries and raw function pointers. Only available on 64 bit linux, mac, and bsd systems. - Allow using `&named` in function prototypes for named arguments. This is a more ergonomic variant of `&keys` that isn't as redundant, more self documenting, and allows extension to things like default arguments. - Add `delay` macro for lazy evaluate-and-save thunks. - Remove pthread.h from janet.h for easier includes. - Add `debugger` - an easy to use debugger function that just takes a fiber. - `dofile` will now start a debugger on errors if the environment it is passed has `:debug` set. - Add `debugger-on-status` function, which can be passed to `run-context` to start a debugger on abnormal fiber signals. - Allow running scripts with the `-d` flag to use the built-in debugger on errors and breakpoints. - Add mutexes (locks) and reader-writer locks to ev module for thread coordination. - Add `parse-all` as a generalization of the `parse` function. - Add `os/cpu-count` to get the number of available processors on a machine ## 1.22.0 - 2022-05-09 - Prohibit negative size argument to `table/new`. - Add `module/value`. - Remove `file/popen`. Use `os/spawn` with the `:pipe` options instead. - Fix bug in peg `thru` and `to` combinators. - Fix printing issue in `doc` macro. - Numerous updates to function docstrings - Add `defdyn` aliases for various dynamic bindings used in core. - Install `janet.h` symlink to make Janet native libraries and applications easier to build without `jpm`. ## 1.21.2 - 2022-04-01 - C functions `janet_dobytes` and `janet_dostring` will now enter the event loop if it is enabled. - Fix hashing regression - hash of negative 0 must be the same as positive 0 since they are equal. - The `flycheck` function no longer pollutes the module/cache - Fix quasiquote bug in compiler - Disallow use of `cancel` and `resume` on fibers scheduled or created with `ev/go`, as well as the root fiber. ## 1.20.0 - 2022-1-27 - Add `:missing-symbol` hook to `compile` that will act as a catch-all macro for undefined symbols. - Add `:redef` dynamic binding that will allow users to redefine top-level bindings with late binding. This is intended for development use. - Fix a bug with reading from a stream returned by `os/open` on Windows and Linux. - Add `:ppc64` as a detectable OS type. - Add `& more` support for destructuring in the match macro. - Add `& more` support for destructuring in all binding forms (`def`). ## 1.19.2 - 2021-12-06 - Fix bug with missing status lines in some stack traces. - Update hash function to have better statistical properties. ## 1.19.1 - 2021-12-04 - Add an optional `prefix` parameter to `debug/stacktrace` to allow printing prettier error messages. - Remove appveyor for CI pipeline - Fixed a bug that prevented sending threaded abstracts over threaded channels. - Fix bug in the `map` function with arity at least 3. ## 1.19.0 - 2021-11-27 - Add `math/log-gamma` to replace `math/gamma`, and change `math/gamma` to be the expected gamma function. - Fix leaking file-descriptors in os/spawn and os/execute. - Ctrl-C will now raise SIGINT. - Allow quoted literals in the `match` macro to behave as expected in patterns. - Fix windows net related bug for TCP servers. - Allow evaluating ev streams with dofile. - Fix `ev` related bug with operations on already closed file descriptors. - Add struct and table agnostic `getproto` function. - Add a number of functions related to structs. - Add prototypes to structs. Structs can now inherit from other structs, just like tables. - Create a struct with a prototype with `struct/with-proto`. - Deadlocked channels will no longer exit early - instead they will hang, which is more intuitive. ## 1.18.1 - 2021-10-16 - Fix some documentation typos - Fix - Set pipes passed to subprocess to blocking mode. - Fix `-r` switch in repl. ## 1.18.0 - 2021-10-10 - Allow `ev/cancel` to work on already scheduled fibers. - Fix bugs with ev/ module. - Add optional `base` argument to scan-number - Add `-i` flag to janet binary to make it easier to run image files from the command line - Remove `thread/` module. - Add `(number ...)` pattern to peg for more efficient number parsing using Janet's scan-number function without immediate string creation. ## 1.17.2 - 2021-09-18 - Remove include of windows.h from janet.h. This caused issues on certain projects. - Fix formatting in doc-format to better handle special characters in signatures. - Fix some marshalling bugs. - Add optional Makefile target to install jpm as well. - Supervisor channels in threads will no longer include a wasteful copy of the fiber in every message across a thread. - Allow passing a closure to `ev/thread` as well as a whole fiber. - Allow passing a closure directly to `ev/go` to spawn fibers on the event loop. ## 1.17.1 - 2021-08-29 - Fix docstring typos - Add `make install-jpm-git` to make jpm co-install simpler if using the Makefile. - Fix bugs with starting ev/threads and fiber marshaling. ## 1.17.0 - 2021-08-21 - Add the `-E` flag for one-liners with the `short-fn` syntax for argument passing. - Add support for threaded abstract types. Threaded abstract types can easily be shared between threads. - Deprecate the `thread` library. Use threaded channels and ev instead. - Channels can now be marshalled. - Add the ability to close channels with `ev/chan-close` (or `:close`). - Add threaded channels with `ev/thread-chan`. - Add `JANET_FN` and `JANET_REG` macros to more easily define C functions that export their source mapping information. - Add `janet_interpreter_interrupt` and `janet_loop1_interrupt` to interrupt the interpreter while running. - Add `table/clear` - Add build option to disable the threading library without disabling all threads. - Remove JPM from the main Janet distribution. Instead, JPM must be installed separately like any other package. - Fix issue with `ev/go` when called with an initial value and supervisor. - Add the C API functions `janet_vm_save` and `janet_vm_load` to allow saving and restoring the entire VM state. ## 1.16.1 - 2021-06-09 - Add `maclintf` - a utility for adding linting messages when inside macros. - Print source code of offending line on compiler warnings and errors. - Fix some issues with linting and re-add missing `make docs`. - Allow controlling linting with dynamic bindings `:lint-warn`, `:lint-error`, and `:lint-levels`. - Add `-w` and `-x` command line flags to the `janet` binary to set linting thresholds. linting thresholds are as follows: - :none - will never be trigger. - :relaxed - will only trigger on `:relaxed` lints. - :normal - will trigger on `:relaxed` and `:normal` lints. - :strict - will trigger on `:strict`, `:normal`, and `:relaxed` lints. This will catch the most issues but can be distracting. ## 1.16.0 - 2021-05-30 - Add color documentation to the `doc` macro - enable/disable with `(dyn :doc-color)`. - Remove simpler HTML docs from distribution - use website or built-in documentation instead. - Add compiler warnings and deprecation levels. - Add `as-macro` to make using macros within quasiquote easier to do hygienically. - Expose `JANET_OUT_OF_MEMORY` as part of the Janet API. - Add `native-deps` option to `declare-native` in `jpm`. This lets native libraries link to other native libraries when building with jpm. - Remove the `tarray` module. The functionality of typed arrays will be moved to an external module that can be installed via `jpm`. - Add `from-pairs` to core. - Add `JPM_OS_WHICH` environment variable to jpm to allow changing auto-detection behavior. - The flychecker will consider any top-level calls of functions that start with `define-` to be safe to execute and execute them. This allows certain patterns (like spork/path) to be better processed by the flychecker. ## 1.15.5 - 2021-04-25 - Add `declare-headers` to jpm. - Fix error using unix pipes on BSDs. - Support .cc and .cxx extensions in `jpm` for C++ code. - Change networking code to not create as many HUP errors. - Add `net/shutdown` to close sockets in one direction without hang ups. - Update code for printing the debug repl ## 1.15.4 - 2021-03-16 - Increase default nesting depth of pretty printing to `JANET_RECURSION_GUARD` - Update meson.build - Add option to automatically add shebang line in installed scripts with `jpm`. - Add `partition-by` and `group-by` to the core. - Sort keys in pretty printing output. ## 1.15.3 - 2021-02-28 - Fix a fiber bug that occurred in deeply nested fibers - Add `unref` combinator to pegs. - Small docstring changes. ## 1.15.2 - 2021-02-15 - Fix bug in windows version of `os/spawn` and `os/execute` with setting environment variables. - Fix documentation typos. - Fix peg integer reading combinators when used with capture tags. ## 1.15.0 - 2021-02-08 - Fix `gtim` and `ltim` bytecode instructions on non-integer values. - Clean up output of flychecking to be the same as the repl. - Change behavior of `debug/stacktrace` with a nil error value. - Add optional argument to `parser/produce`. - Add `no-core` option to creating standalone binaries to make execution faster. - Fix bug where a buffer overflow could be confused with an out of memory error. - Change error output to `file:line:column: message`. Column is in bytes - tabs are considered to have width 1 (instead of 8). ## 1.14.2 - 2021-01-23 - Allow `JANET_PROFILE` env variable to load a profile before loading the repl. - Update `tracev` macro to allow `def` and `var` inside to work as expected. - Use `(dyn :peg-grammar)` for passing a default grammar to `peg/compile` instead of loading `default-peg-grammar` directly from the root environment. - Add `ev/thread` for combining threading with the event loop. - Add `ev/do-thread` to make `ev/thread` easier to use. - Automatically set supervisor channel in `net/accept-loop` and `net/server` correctly. ## 1.14.1 - 2021-01-18 - Add `doc-of` for reverse documentation lookup. - Add `ev/give-supervsior` to send a message to the supervising channel. - Add `ev/gather` and `chan` argument to `ev/go`. This new argument allows "supervisor channels" for fibers to enable structured concurrency. - Make `-k` flag work on stdin if no files are given. - Add `flycheck` function to core. - Make `backmatch` and `backref` more expressive in pegs. - Fix buggy `string/split`. - Add `fiber/last-value` to get the value that was last yielded, errored, or signaled by a fiber. - Remove `:generate` verb from `loop` macros. Instead, use the `:in` verb which will now work on fibers as well as other data structures. - Define `next`, `get`, and `in` for fibers. This lets `each`, `map`, and similar iteration macros can now iterate over fibers. - Remove macro `eachy`, which can be replaced by `each`. - Add `dflt` argument to find-index. - Deprecate `file/popen` in favor of `os/spawn`. - Add `:all` keyword to `ev/read` and `net/read` to make them more like `file/read`. However, we do not provide any `:line` option as that requires buffering. - Change repl behavior to make Ctrl-C raise SIGINT on posix. The old behavior for Ctrl-C, to clear the current line buffer, has been moved to Ctrl-Q. - Importing modules that start with `/` is now the only way to import from project root. Before, this would import from / on disk. Previous imports that did not start with `.` or `/` are now unambiguously importing from the syspath, instead of checking both the syspath and the project root. This is backwards incompatible and dependencies should be updated for this. - Change hash function for numbers. - Improve error handling of `dofile`. - Bug fixes in networking and subprocess code. - Use markdown formatting in more places for docstrings. ## 1.13.1 - 2020-12-13 - Pretty printing a table with a prototype will look for `:_name` instead of `:name` in the prototype table to tag the output. - `match` macro implementation changed to be tail recursive. - Adds a :preload loader which allows one to manually put things into `module/cache`. - Add `buffer/push` function. - Backtick delimited strings and buffers are now reindented based on the column of the opening delimiter. Whitespace in columns to the left of the starting column is ignored unless there are non-space/non-newline characters in that region, in which case the old behavior is preserved. - Argument to `(error)` combinator in PEGs is now optional. - Add `(line)` and `(column)` combinators to PEGs to capture source line and column. This should make error reporting a bit easier. - Add `merge-module` to core. - During installation and release, merge janetconf.h into janet.h for easier install. - Add `upscope` special form. - `os/execute` and `os/spawn` can take streams for redirecting IO. - Add `:parser` and `:read` parameters to `run-context`. - Add `os/open` if ev is enabled. - Add `os/pipe` if ev is enabled. - Add `janet_thread_current(void)` to C API - Add integer parsing forms to pegs. This makes parsing many binary protocols easier. - Lots of updates to networking code - now can use epoll (or poll) on linux and IOCP on windows. - Add `ev/` module. This exposes a fiber scheduler, queues, timeouts, and other functionality to users for single threaded cooperative scheduling and asynchronous IO. - Add `net/accept-loop` and `net/listen`. These functions break down `net/server` into it's essential parts and are more flexible. They also allow further improvements to these utility functions. - Various small bug fixes. ## 1.12.2 - 2020-09-20 - Add janet\_try and janet\_restore to C API. - Fix `os/execute` regression on windows. - Add :pipe option to `os/spawn`. - Fix docstring typos. ## 1.12.1 - 2020-09-07 - Make `zero?`, `one?`, `pos?`, and `neg?` polymorphic. - Add C++ support to jpm and improve C++ interop in janet.h. - Add `%t` formatter to `printf`, `string/format`, and other formatter functions. - Expose `janet_cfuns_prefix` in C API. - Add `os/proc-wait` and `os/proc-kill` for interacting with processes. - Add `janet_getjfile` to C API. - Allow redirection of stdin, stdout, and stderr by passing keywords in the env table in `os/spawn` and `os/execute`. - Add `os/spawn` to get a core/process back instead of an exit code as in `os/execute`. When called like this, `os/execute` returns immediately. - Add `:x` flag to os/execute to raise error when exit code is non-zero. - Don't run `main` when flychecking. - Add `:n` flag to `file/open` to raise an error if file cannot be opened. - Fix import macro to not try and coerce everything to a string. - Allow passing a second argument to `disasm`. - Add `cancel`. Resumes a fiber but makes it immediately error at the yield point. - Allow multi-line paste into built in repl. - Add `(curenv)`. - Change `net/read`, `net/chunk`, and `net/write` to raise errors in the case of failures. - Add `janet_continue_signal` to C API. This indirectly enables C functions that yield to the event loop to raise errors or other signals. - Update meson build script to fix bug on Debian's version of meson - Add `xprint`, `xprin`, `xprintf`, and `xprinf`. - `net/write` now raises an error message if write fails. - Fix issue with SIGPIPE on macOS and BSDs. ## 1.11.3 - 2020-08-03 - Add `JANET_HASHSEED` environment variable when `JANET_PRF` is enabled. - Expose `janet_cryptorand` in C API. - Properly initialize PRF in default janet program - Add `index-of` to core library. - Add `-fPIC` back to core CFLAGS (non-optional when compiling default client with Makefile) - Fix defaults on Windows for ARM - Fix defaults on NetBSD. ## 1.11.1 - 2020-07-25 - Fix jpm and git with multiple git installs on Windows - Fix importing a .so file in the current directory - Allow passing byte sequence types directly to typed-array constructors. - Fix bug sending files between threads. - Disable PRF by default. - Update the soname. ## 1.11.0 - 2020-07-18 - Add `forever` macro. - Add `any?` predicate to core. - Add `jpm list-pkgs` subcommand to see which package aliases are in the listing. - Add `jpm list-installed` subcommand to see which packages are installed. - Add `math/int-min`, `math/int-max`, `math/int32-min`, and `math/int32-max` for getting integer limits. - The gc interval is now autotuned, to prevent very bad gc behavior. - Improvements to the bytecode compiler, Janet will now generate more efficient bytecode. - Add `peg/find`, `peg/find-all`, `peg/replace`, and `peg/replace-all` - Add `math/nan` - Add `forv` macro - Add `symbol/slice` - Add `keyword/slice` - Allow cross compilation with Makefile. - Change `compare-primitive` to `cmp` and make it more efficient. - Add `reverse!` for reversing an array or buffer in place. - `janet_dobytes` and `janet_dostring` return parse errors in \*out - Add `repeat` macro for iterating something n times. - Add `eachy` (each yield) macro for iterating a fiber. - Fix `:generate` verb in loop macro to accept non symbols as bindings. - Add `:h`, `:h+`, and `:h*` in `default-peg-grammar` for hexadecimal digits. - Fix `%j` formatter to print numbers precisely (using the `%.17g` format string to printf). ## 1.10.1 - 2020-06-18 - Expose `janet_table_clear` in API. - Respect `JANET_NO_PROCESSES` define when building - Fix `jpm` rules having multiple copies of the same dependency. - Fix `jpm` install in some cases. - Add `array/trim` and `buffer/trim` to shrink the backing capacity of these types to their current length. ## 1.10.0 - 2020-06-14 - Hardcode default jpm paths on install so env variables are needed in fewer cases. - Add `:no-compile` to `create-executable` option for jpm. - Fix bug with the `trace` function. - Add `:h`, `:a`, and `:c` flags to `thread/new` for creating new kinds of threads. By default, threads will now consume much less memory per thread, but sending data between threads may cost more. - Fix flychecking when using the `use` macro. - CTRL-C no longer exits the repl, and instead cancels the current form. - Various small bug fixes - New MSI installer instead of NSIS based installer. - Make `os/realpath` work on windows. - Add polymorphic `compare` functions for comparing numbers. - Add `to` and `thru` peg combinators. - Add `JANET_GIT` environment variable to jpm to use a specific git binary (useful mainly on windows). - `asm` and `disasm` functions now use keywords instead of macros for keys. Also some slight changes to the way constants are encoded (remove wrapping `quote` in some cases). - Expose current macro form inside macros as (dyn :macro-form) - Add `tracev` macro. - Fix compiler bug that emitted incorrect code in some cases for while loops that create closures. - Add `:fresh` option to `(import ...)` to overwrite the module cache. - `(range x y 0)` will return an empty array instead of hanging forever. - Rename `jpm repl` to `jpm debug-repl`. ## 1.9.1 - 2020-05-12 - Add :prefix option to declare-source - Re-enable minimal builds with the debugger. - Add several flags for configuring Janet on different platforms. - Fix broken meson build from 1.9.0 and add meson to CI. - Fix compilation issue when nanboxing is disabled. ## 1.9.0 - 2020-05-10 - Add `:ldflags` option to many jpm declare functions. - Add `errorf` to core. - Add `lenprefix` combinator to PEGs. - Add `%M`, `%m`, `%N`, and `%n` formatters to formatting functions. These are the same as `%Q`, `%q`, `%P`, and `%p`, but will not truncate long values. - Add `fiber/root`. - Add beta `net/` module to core for socket based networking. - Add the `parse` function to parse strings of source code more conveniently. - Add `jpm rule-tree` subcommand. - Add `--offline` flag to jpm to force use of the cache. - Allow sending pointers and C functions across threads via `thread/send`. - Fix bug in `getline`. - Add `sh-rule` and `sh-phony` to jpm's dialect of Janet. - Change C api's `janet_formatb` -> `janet_formatbv`, and add new function `janet_formatb` to C api. - Add `edefer` macro to core. - A struct/table literal/constructor with duplicate keys will use the last value given. Previously, this was inconsistent between tables and structs, literals and constructor functions. - Add debugger to core. The debugger functions are only available in a debug repl, and are prefixed by a `.`. - Add `sort-by` and `sorted-by` to core. - Support UTF-8 escapes in strings via `\uXXXX` or `\UXXXXXX`. - Add `math/erf` - Add `math/erfc` - Add `math/log1p` - Add `math/next` - Add os/umask - Add os/perm-int - Add os/perm-string - Add :int-permissions option for os/stat. - Add `jpm repl` subcommand, as well as `post-deps` macro in project.janet files. - Various bug fixes. ## 1.8.1 - 2020-03-31 - Fix bugs for big endian systems - Fix 1.8.0 regression on BSDs ## 1.8.0 - 2020-03-29 - Add `reduce2`, `accumulate`, and `accumulate2`. - Add lockfiles to `jpm` via `jpm make-lockfile` and `jpm load-lockfile`. - Add `os/realpath` (Not supported on windows). - Add `os/chmod`. - Add `chr` macro. - Allow `_` in the `match` macro to match anything without creating a binding or doing unification. Also change behavior of matching nil. - Add `:range-to` and `:down-to` verbs in the `loop` macro. - Fix `and` and `or` macros returning nil instead of false in some cases. - Allow matching successfully against nil values in the `match` macro. - Improve `janet_formatc` and `janet_panicf` formatters to be more like `string/format`. This makes it easier to make nice error messages from C. - Add `signal` - Add `fiber/can-resume?` - Allow fiber functions to accept arguments that are passed in via `resume`. - Make flychecking slightly less strict but more useful - Correct arity for `next` - Correct arity for `marshal` - Add `flush` and `eflush` - Add `prompt` and `return` on top of signal for user friendly delimited continuations. - Fix bug in buffer/blit when using the offset-src argument. - Fix segfault with malformed pegs. ## 1.7.0 - 2020-02-01 - Remove `file/fileno` and `file/fdopen`. - Remove `==`, `not==`, `order<`, `order>`, `order<=`, and `order>=`. Instead, use the normal comparison and equality functions. - Let abstract types define a hash function and comparison/equality semantics. This lets abstract types much better represent value types. This adds more fields to abstract types, which will generate warnings when compiled against other versions. - Remove Emscripten build. Instead, use the amalgamated source code with a custom toolchain. - Update documentation. - Add `var-` - Add `module/add-paths` - Add `file/temp` - Add `mod` function to core. - Small bug fixes - Allow signaling from C functions (yielding) via janet\_signalv. This makes it easy to write C functions that work with event loops, such as in libuv or embedded in a game. - Add '%j' formatting option to the format family of functions. - Add `defer` - Add `assert` - Add `when-with` - Add `if-with` - Add completion to the default repl based on currently defined bindings. Also generally improve the repl keybindings. - Add `eachk` - Add `eachp` - Improve functionality of the `next` function. `next` now works on many different types, not just tables and structs. This allows for more generic data processing. - Fix thread module issue where sometimes decoding a message failed. - Fix segfault regression when macros are called with bad arity. ## 1.6.0 - 2019-12-22 - Add `thread/` module to the core. - Allow seeding RNGs with any sequence of bytes. This provides a wider key space for the RNG. Exposed in C as `janet_rng_longseed`. - Fix issue in `resume` and similar functions that could cause breakpoints to be skipped. - Add a number of new math functions. - Improve debugger experience and capabilities. See examples/debugger.janet for what an interactive debugger could look like. - Add `debug/step` (janet\_step in the C API) for single stepping Janet bytecode. - The built in repl now can enter the debugger on any signal (errors, yields, user signals, and debug signals). To enable this, type (setdyn :debug true) in the repl environment. - When exiting the debugger, the fiber being debugged is resumed with the exit value of the debug session (the value returned by `(quit return-value)`, or nil if user typed Ctrl-D). - `(quit)` can take an optional argument that is the return value. If a module contains `(quit some-value)`, the value of that module returned to `(require "somemod")` is the return value. This lets module writers completely customize a module without writing a loader. - Add nested quasiquotation. - Add `os/cryptorand` - Add `prinf` and `eprinf` to be have like `printf` and `eprintf`. The latter two functions now including a trailing newline, like the other print functions. - Add nan? - Add `janet_in` to C API. - Add `truthy?` - Add `os/environ` - Add `buffer/fill` and `array/fill` - Add `array/new-filled` - Use `(doc)` with no arguments to see available bindings and dynamic bindings. - `jpm` will use `CC` and `AR` environment variables when compiling programs. - Add `comptime` macro for compile time evaluation. - Run `main` functions in scripts if they exist, just like jpm standalone binaries. - Add `protect` macro. - Add `root-env` to get the root environment table. - Change marshalling protocol with regard to abstract types. - Add `show-paths` to `jpm`. - Add several default patterns, like `:d` and `:s+`, to PEGs. - Update `jpm` path settings to make using `jpm` easier on non-global module trees. - Numerous small bug fixes and usability improvements. ### 1.5.1 - 2019-11-16 - Fix bug when printing buffer to self in some edge cases. - Fix bug with `jpm` on windows. - Fix `update` return value. ## 1.5.0 - 2019-11-10 - `os/date` now defaults to UTC. - Add `--test` flag to jpm to test libraries on installation. - Add `math/rng`, `math/rng-int`, and `math/rng-uniform`. - Add `in` function to index in a stricter manner. Conversely, `get` will now not throw errors on bad keys. - Indexed types and byte sequences will now error when indexed out of range or with bad keys. - Add rng functions to Janet. This also replaces the RNG behind `math/random` and `math/seedrandom` with a consistent, platform independent RNG. - Add `with-vars` macro. - Add the `quickbin` command to jpm. - Create shell.c when making the amalgamated source. This can be compiled with janet.c to make the janet interpreter. - Add `cli-main` function to the core, which invokes Janet's CLI interface. This basically moves what was init.janet into boot.janet. - Improve flychecking, and fix flychecking bugs introduced in 1.4.0. - Add `prin`, `eprint`, `eprintf` and `eprin` functions. The functions prefix with e print to `(dyn :err stderr)` - Print family of functions can now also print to buffers (before, they could only print to files.) Output can also be completely disabled with `(setdyn :out false)`. - `printf` is now a c function for optimizations in the case of printing to buffers. ## 1.4.0 - 2019-10-14 - Add `quit` function to exit from a repl, but not always exit the entire application. - Add `update-pkgs` to jpm. - Integrate jpm with https://github.com/janet-lang/pkgs.git. jpm can now install packages based on their short names in the package listing, which can be customized via an env variable. - Add `varfn` macro - Add compile time arity checking when function in function call is known. - Added `slice` to the core library. - The `*/slice` family of functions now can take nil as start or end to get the same behavior as the defaults (0 and -1) for those parameters. - `string/` functions that take a pattern to search for will throw an error when receiving the empty string. - Replace (start:end) style stacktrace source position information with line, column. This should be more readable for humans. Also, range information can be recovered by re-parsing source. ## 1.3.1 - 2019-09-21 - Fix some linking issues when creating executables with native dependencies. - jpm now runs each test script in a new interpreter. - Fix an issue that prevent some valid programs from compiling. - Add `mean` to core. - Abstract types that implement the `:+`, `:-`, `:*`, `:/`, `:>`, `:==`, `:<`, `:<=`, and `:>=` methods will work with the corresponding built-in arithmetic functions. This means built-in integer types can now be used as normal number values in many contexts. - Allow (length x) on typed arrays an other abstract types that implement the :length method. ## 1.3.0 - 2019-09-05 - Add `get-in`, `put-in`, `update-in`, and `freeze` to core. - Add `jpm run rule` and `jpm rules` to jpm to improve utility and discoverability of jpm. - Remove `cook` module and move `path` module to https://github.com/janet-lang/path.git. The functionality in `cook` is now bundled directly in the `jpm` script. - Add `buffer/format` and `string/format` format flags `Q` and `q` to print colored and non-colored single-line values, similar to `P` and `p`. - Change default repl to print long sequences on one line and color stacktraces if color is enabled. - Add `backmatch` pattern for PEGs. - jpm detects if not in a Developer Command prompt on windows for a better error message. - jpm install git submodules in dependencies - Change default fiber stack limit to the maximum value of a 32 bit signed integer. - Some bug fixes with `jpm` - Fix bugs with pegs. - Add `os/arch` to get ISA that janet was compiled for - Add color to stacktraces via `(dyn :err-color)` ## 1.2.0 - 2019-08-08 - Add `take` and `drop` functions that are easier to use compared to the existing slice functions. - Add optional default value to `get`. - Add function literal short-hand via `|` reader macro, which maps to the `short-fn` macro. - Add `int?` and `nat?` functions to the core. - Add `(dyn :executable)` at top level to get what used to be `(process/args 0)`. - Add `:linux` to platforms returned by `(os/which)`. - Update jpm to build standalone executables. Use `declare-executable` for this. - Add `use` macro. - Remove `process/args` in favor of `(dyn :args)`. - Fix bug with Nanbox implementation allowing users to created custom values of any type with typed array and marshal modules, which was unsafe. - Add `janet_wrap_number_safe` to API, for converting numbers to Janets where the number could be any 64 bit, user provided bit pattern. Certain NaN values (which a machine will never generate as a result of a floating point operation) are guarded against and converted to a default NaN value. ## 1.1.0 - 2019-07-08 - Change semantics of `-l` flag to be import rather than dofile. - Fix compiler regression in top level defs with destructuring. - Add `table/clone`. - Improve `jpm` tool with git and dependency capabilities, as well as better module uninstalls. ## 1.0.0 - 2019-07-01 - Add `with` macro for resource handling. - Add `propagate` function so we can "rethrow" signals after they are intercepted. This makes signals even more flexible. - Add `JANET_NO_DOCSTRINGS` and `JANET_NO_SOURCEMAPS` defines in janetconf.h for shrinking binary size. This seems to save about 50kB in most builds, so it's not usually worth it. - Update module system to allow relative imports. The `:cur:` pattern in `module/expand-path` will expand to the directory part of the current file, or whatever the value of `(dyn :current-file)` is. The `:dir:` pattern gets the directory part of the input path name. - Remove `:native:` pattern in `module/paths`. - Add `module/expand-path` - Remove `module/*syspath*` and `module/*headerpath*` in favor of dynamic bindings `:syspath` and `:headerpath`. - Compiled PEGs can now be marshaled and unmarshaled. - Change signature to `parser/state` - Add `:until` verb to loop. - Add `:p` flag to `fiber/new`. - Add `file/{fdopen,fileno}` functions. - Add `parser/clone` function. - Add optional argument to `parser/where` to set parser byte index. - Add optional `env` argument to `all-bindings` and `all-dynamics`. - Add scratch memory C API functions for auto-released memory on next gc. Scratch memory differs from normal GCed memory as it can also be freed normally for better performance. - Add API compatibility checking for modules. This will let native modules not load when the host program is not of a compatible version or configuration. - Change signature of `os/execute` to be much more flexible. ## 0.6.0 - 2019-05-29 - `file/close` returns exit code when closing file opened with `file/popen`. - Add `os/rename` - Update windows installer to include tools like `jpm`. - Add `jpm` tool for building and managing projects. - Change interface to `cook` tool. - Add optional filters to `module/paths` to further refine import methods. - Add keyword arguments via `&keys` in parameter list. - Add `-k` flag for flychecking source. - Change signature to `compile` function. - Add `module/loaders` for custom loading functions. - Add external unification to `match` macro. - Add static library to main build. - Add `janet/*headerpath*` and change location of installed headers. - Let `partition` take strings. - Haiku OS support - Add `string/trim`, `string/trimr`, and `string/triml`. - Add `dofile` function. - Numbers require at least 1 significant digit. - `file/read` will return nil on end of file. - Fix various bugs. ## 0.5.0 - 2019-05-09 - Fix some bugs with buffers. - Add `trace` and `untrace` to the core library. - Add `string/has-prefix?` and `string/has-suffix?` to string module. - Add simple debugger to repl that activates on errors or debug signal - Remove `*env*` and `*doc-width*`. - Add `fiber/getenv`, `fiber/setenv`, and `dyn`, and `setdyn`. - Add support for dynamic bindings (via the `dyn` and `setdyn` functions). - Change signatures of some functions like `eval` which no longer takes an optional environment. - Add printf function - Make `pp` configurable with dynamic binding `:pretty-format`. - Remove the `meta` function. - Add `with-dyns` for blocks with dynamic bindings assigned. - Allow leading and trailing newlines in backtick-delimited string (long strings). These newlines will not be included in the actual string value. ## 0.4.1 - 2019-04-14 - Squash some bugs - Peg patterns can now make captures in any position in a grammar. - Add color to repl output - Add array/remove function - Add meson build support - Add int module for int types - Add meson build option - Add (break) special form and improve loop macro - Allow abstract types to specify custom tostring method - Extend C API for marshalling abstract types and other values - Add functions to `os` module. ## 0.4.0 - 2019-03-08 - Fix a number of smaller bugs - Added :export option to import and require - Added typed arrays - Remove `callable?`. - Remove `tuple/append` and `tuple/prepend`, which may have seemed like `O(1)` operations. Instead, use the `splice` special to extend tuples. - Add `-m` flag to main client to allow specifying where to load system modules from. - Add `-c` flag to main client to allow compiling Janet modules to images. - Add `string/format` and `buffer/format`. - Remove `string/pretty` and `string/number`. - `make-image` function creates pre compiled images for janet. These images link to the core library. They can be loaded via require or manually via `load-image`. - Add bracketed tuples as tuple constructor. - Add partition function to core library. - Pre-compile core library into an image for faster startup. - Add methods to parser values that mirror the api. - Add janet\_getmethod to CAPI for easier use of method like syntax. - Add get/set to abstract types to allow them to behave more like objects with methods. - Add parser/insert to modify parser state programmatically - Add debug/stacktrace for easy, pretty stacktraces - Remove the status-pp function - Update API to run-context to be much more sane - Add :lflags option to cook/make-native - Disallow NaNs as table or struct keys - Update module resolution paths and format ## 0.3.0 - 2019-01-26 - Add amalgamated build to janet for easier embedding. - Add os/date function - Add slurp and spit to core library. - Added this changelog. - Added peg module (Parsing Expression Grammars) - Move hand written documentation into website repository. janet-1.41.2/CONTRIBUTING.md000066400000000000000000000107401514534607600151460ustar00rootroot00000000000000# Guidelines for contributing to Janet Thanks for taking time to contribute to Janet! Please read this document before making contributions. ## Reporting bugs * Check past and current issues to see if your problem has been run into before. * If you can't find a past issue for your problem, or if the issues has been closed you should open a new issue. If there is a closed issue that is relevant, make sure to reference it. * As with any project, include a comprehensive description of the problem and instructions on how to reproduce it. If it is a compiler or language bug, please try to include a minimal example. This means don't post all 200 lines of code from your project, but spend some time distilling the problem to just the relevant code. ## Contributing Changes If you want to contribute some code to the project, please submit a pull request and follow the below guidelines. Not all changes will be merged, and some pull requests may require changes before being merged. * Include a description of the changes. * If there are changes to the compiler or the language, please include tests in the test folder. The test suites are not organized in any particular way now, so simply add your tests to one of the test suite files (test/suite0.janet, test/suite1.janet, etc.). You can run tests with `make test`. If you want to add a new test suite, simply add a file to the test folder and make sure it is run when`make test` is invoked. * Be consistent with the style. For C this means follow the indentation and style in other files (files have MIT license at top, 4 spaces indentation, no trailing whitespace, cuddled brackets, etc.) Use `make format` to automatically format your C code with [astyle](http://astyle.sourceforge.net/astyle.html). You will probably need to install this, but it can be installed with most package managers. For janet code, use lisp indentation with 2 spaces. One can use janet.vim to do this indentation, or approximate as close as possible. There is a janet formatter in [spork](https://github.com/janet-lang/spork.git) that can be used to format code as well. ## C style For changes to the VM and Core code, you will probably need to know C. Janet is programmed with a subset of C99 that works with Microsoft Visual C++. This means most of C99 but with the following omissions. * No `restrict` * Certain functions in the standard library are not always available In practice, this means programming for both MSVC on one hand and everything else on the other. The code must also build with emscripten, even if some features are not available, although this is not a priority. Code should compile warning free and run valgrind clean. I find that these two criteria are some of the easiest ways to protect against a large number of bugs in an unsafe language like C. To check for valgrind errors, run `make valtest` and check the output for undefined or flagged behavior. ### Formatting Use [astyle](http://astyle.sourceforge.net/astyle.html) via `make format` to ensure a consistent code style for C. ## Janet style All janet code in the project should be formatted similar to the code in src/boot/boot.janet. The auto formatting from janet.vim will work well. ## Typo Fixing and One-Line changes Typo fixes are welcome, as are simple one line fixes. Do not open many separate pull requests for each individual typo fix. This is incredibly annoying to deal with as someone needs to review each PR, run CI, and merge. Instead, accumulate batches of typo fixes into a single PR. If there are objections to specific changes, these can be addressed in the review process before the final merge, if the changes are accepted. Similarly, low effort and bad faith changes are annoying to developers and such issues may be closed immediately without response. ## Contributions from Automated Tools People making changes found or generated by automated tools MUST note this when opening an issue or creating a pull request. This can help give context to developers if the change/issue is confusing or nonsensical. ## Suggesting Changes To suggest changes, open an issue on GitHub. Check GitHub for other issues that may be related to your issue before opening a new suggestion. Suggestions put forth without code will be considered, but not necessarily implemented in any timely manner. In short, if you want extra functionality now, then build it. * Include a good description of the problem that is being solved * Include descriptions of potential solutions if you have some in mind. janet-1.41.2/LICENSE000066400000000000000000000020601514534607600137160ustar00rootroot00000000000000Copyright (c) 2026 Calvin Rose and contributors Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. janet-1.41.2/Makefile000066400000000000000000000347451514534607600143700ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. ################################ ##### Set global variables ##### ################################ sinclude config.mk PREFIX?=/usr/local JANETCONF_HEADER?=src/conf/janetconf.h INCLUDEDIR?=$(PREFIX)/include BINDIR?=$(PREFIX)/bin LIBDIR?=$(PREFIX)/lib JANET_BUILD?="\"$(shell git log --pretty=format:'%h' -n 1 2> /dev/null || echo local)\"" CLIBS=-lm -lpthread JANET_TARGET=build/janet JANET_BOOT=build/janet_boot JANET_IMPORT_LIB=build/janet.lib JANET_LIBRARY_IMPORT_LIB=build/libjanet.lib JANET_LIBRARY=build/libjanet.so JANET_STATIC_LIBRARY=build/libjanet.a JANET_PATH?=$(LIBDIR)/janet JANET_MANPATH?=$(PREFIX)/share/man/man1/ JANET_PKG_CONFIG_PATH?=$(LIBDIR)/pkgconfig JANET_DIST_DIR?=janet-dist JANET_BOOT_FLAGS:=. JANET_PATH '$(JANET_PATH)' JANET_TARGET_OBJECTS=build/janet.o build/shell.o JPM_TAG?=master SPORK_TAG?=master HAS_SHARED?=1 DEBUGGER=gdb SONAME_SETTER=-Wl,-soname, STRIPFLAGS=-x -S # For cross compilation HOSTCC?=$(CC) HOSTAR?=$(AR) # Symbols are (optionally) removed later, keep -g as default! CFLAGS?=-O2 -g LDFLAGS?=-rdynamic LIBJANET_LDFLAGS?=$(LDFLAGS) RUN:=$(RUN) COMMON_CFLAGS:=-std=c99 -Wall -Wextra -Isrc/include -Isrc/conf -fvisibility=hidden -fPIC BOOT_CFLAGS:=-DJANET_BOOTSTRAP -DJANET_BUILD=$(JANET_BUILD) -O0 $(COMMON_CFLAGS) -g BUILD_CFLAGS:=$(CFLAGS) $(COMMON_CFLAGS) # Disable amalgamated build ifeq ($(JANET_NO_AMALG), 1) JANET_TARGET_OBJECTS+=$(patsubst src/%.c,build/%.bin.o,$(JANET_CORE_SOURCES)) JANET_BOOT_FLAGS+=image-only endif # For installation LDCONFIG:=ldconfig "$(LIBDIR)" # Check OS UNAME?=$(shell uname -s) ifeq ($(UNAME), Darwin) CLIBS:=$(CLIBS) -ldl SONAME_SETTER:=-Wl,-install_name, JANET_LIBRARY=build/libjanet.dylib LDCONFIG:=true else ifeq ($(UNAME), Linux) CLIBS:=$(CLIBS) -lrt -ldl else ifeq ($(UNAME), SunOS) BUILD_CFLAGS+=-D__EXTENSIONS__ -DJANET_NO_NANBOX BOOT_CFLAGS+=-D__EXTENSIONS__ -DJANET_NO_NANBOX CLIBS:=-lsocket -lm STRIPFLAGS=-x LDCONFIG:=false endif # For other unix likes, add flags here! ifeq ($(UNAME), Haiku) LDCONFIG:=true LDFLAGS=-Wl,--export-dynamic endif # For Android (termux) ifeq ($(UNAME), Linux) # uname on Darwin doesn't recognise -o ifeq ($(shell uname -o), Android) CLIBS:=$(CLIBS) -landroid-spawn endif endif # Mingw MINGW_COMPILER= ifeq ($(findstring MINGW,$(UNAME)), MINGW) MINGW_COMPILER=gcc CLIBS:=-lws2_32 -lpsapi -lwsock32 LDFLAGS:=-Wl,--out-implib,$(JANET_IMPORT_LIB) LIBJANET_LDFLAGS:=-Wl,--out-implib,$(JANET_LIBRARY_IMPORT_LIB) JANET_TARGET:=$(JANET_TARGET).exe JANET_BOOT:=$(JANET_BOOT).exe COMPILER_VERSION:=$(shell $(CC) --version) ifeq ($(findstring clang,$(COMPILER_VERSION)), clang) MINGW_COMPILER=clang endif endif $(shell mkdir -p build/core build/c build/boot build/mainclient) all: $(JANET_TARGET) $(JANET_STATIC_LIBRARY) build/janet.h ifeq ($(HAS_SHARED), 1) all: $(JANET_LIBRARY) endif ###################### ##### Name Files ##### ###################### JANET_HEADERS=src/include/janet.h $(JANETCONF_HEADER) JANET_LOCAL_HEADERS=src/core/features.h \ src/core/util.h \ src/core/state.h \ src/core/gc.h \ src/core/vector.h \ src/core/fiber.h \ src/core/regalloc.h \ src/core/compile.h \ src/core/emit.h \ src/core/symcache.h JANET_CORE_SOURCES=src/core/abstract.c \ src/core/array.c \ src/core/asm.c \ src/core/buffer.c \ src/core/bytecode.c \ src/core/capi.c \ src/core/cfuns.c \ src/core/compile.c \ src/core/corelib.c \ src/core/debug.c \ src/core/emit.c \ src/core/ev.c \ src/core/ffi.c \ src/core/fiber.c \ src/core/filewatch.c \ src/core/gc.c \ src/core/inttypes.c \ src/core/io.c \ src/core/marsh.c \ src/core/math.c \ src/core/net.c \ src/core/os.c \ src/core/parse.c \ src/core/peg.c \ src/core/pp.c \ src/core/regalloc.c \ src/core/run.c \ src/core/specials.c \ src/core/state.c \ src/core/string.c \ src/core/strtod.c \ src/core/struct.c \ src/core/symcache.c \ src/core/table.c \ src/core/tuple.c \ src/core/util.c \ src/core/value.c \ src/core/vector.c \ src/core/vm.c \ src/core/wrap.c JANET_BOOT_SOURCES=src/boot/array_test.c \ src/boot/boot.c \ src/boot/buffer_test.c \ src/boot/number_test.c \ src/boot/system_test.c \ src/boot/table_test.c JANET_BOOT_HEADERS=src/boot/tests.h ########################################################## ##### The bootstrap interpreter that creates janet.c ##### ########################################################## JANET_BOOT_OBJECTS=$(patsubst src/%.c,build/%.boot.o,$(JANET_CORE_SOURCES) $(JANET_BOOT_SOURCES)) $(JANET_BOOT_OBJECTS): $(JANET_BOOT_HEADERS) build/%.boot.o: src/%.c $(JANET_HEADERS) $(JANET_LOCAL_HEADERS) Makefile $(CC) $(BOOT_CFLAGS) -o $@ -c $< $(JANET_BOOT): $(JANET_BOOT_OBJECTS) $(CC) $(BOOT_CFLAGS) -o $@ $(JANET_BOOT_OBJECTS) $(CLIBS) # Now the reason we bootstrap in the first place build/c/janet.c: $(JANET_BOOT) src/boot/boot.janet $(RUN) $(JANET_BOOT) $(JANET_BOOT_FLAGS) > $@ cksum $@ ################## ##### Quicky ##### ################## build/%.bin.o: src/%.c $(JANET_HEADERS) $(JANET_LOCAL_HEADERS) Makefile $(HOSTCC) $(BUILD_CFLAGS) -o $@ -c $< ######################## ##### Amalgamation ##### ######################## ifeq ($(UNAME), Darwin) SONAME=libjanet.1.41.dylib else SONAME=libjanet.so.1.41 endif ifeq ($(MINGW_COMPILER), clang) SONAME= SONAME_SETTER= endif build/c/shell.c: src/mainclient/shell.c cp $< $@ build/janet.h: $(JANET_TARGET) src/include/janet.h $(JANETCONF_HEADER) $(RUN) ./$(JANET_TARGET) tools/patch-header.janet src/include/janet.h $(JANETCONF_HEADER) $@ build/janetconf.h: $(JANETCONF_HEADER) cp $< $@ build/janet.o: build/c/janet.c $(JANETCONF_HEADER) src/include/janet.h $(HOSTCC) $(BUILD_CFLAGS) -c $< -o $@ build/shell.o: build/c/shell.c $(JANETCONF_HEADER) src/include/janet.h $(HOSTCC) $(BUILD_CFLAGS) -c $< -o $@ $(JANET_TARGET): $(JANET_TARGET_OBJECTS) $(HOSTCC) $(LDFLAGS) $(BUILD_CFLAGS) -o $@ $^ $(CLIBS) $(JANET_LIBRARY): $(JANET_TARGET_OBJECTS) $(HOSTCC) $(LIBJANET_LDFLAGS) $(BUILD_CFLAGS) $(SONAME_SETTER)$(SONAME) -shared -o $@ $^ $(CLIBS) $(JANET_STATIC_LIBRARY): $(JANET_TARGET_OBJECTS) $(HOSTAR) rcs $@ $^ ################### ##### Testing ##### ################### # Testing assumes HOSTCC=CC TEST_SCRIPTS=$(wildcard test/suite*.janet) EXAMPLE_SCRIPTS=$(wildcard examples/*.janet) repl: $(JANET_TARGET) $(RUN) ./$(JANET_TARGET) debug: $(JANET_TARGET) $(DEBUGGER) ./$(JANET_TARGET) VALGRIND_COMMAND=$(RUN) valgrind --leak-check=full --quiet CALLGRIND_COMMAND=$(RUN) valgrind --tool=callgrind valgrind: $(JANET_TARGET) $(VALGRIND_COMMAND) ./$(JANET_TARGET) test: $(JANET_TARGET) $(TEST_SCRIPTS) $(EXAMPLE_SCRIPTS) for f in test/suite*.janet; do $(RUN) ./$(JANET_TARGET) "$$f" || exit; done for f in examples/*.janet; do $(RUN) ./$(JANET_TARGET) -k "$$f"; done valtest: $(JANET_TARGET) $(TEST_SCRIPTS) $(EXAMPLE_SCRIPTS) for f in test/suite*.janet; do $(VALGRIND_COMMAND) ./$(JANET_TARGET) "$$f" || exit; done for f in examples/*.janet; do $(VALGRIND_COMMAND) ./$(JANET_TARGET) -k "$$f"; done callgrind: $(JANET_TARGET) $(CALLGRIND_COMMAND) ./$(JANET_TARGET) calltest: $(JANET_TARGET) $(TEST_SCRIPTS) $(EXAMPLE_SCRIPTS) for f in test/suite*.janet; do $(CALLGRIND_COMMAND) ./$(JANET_TARGET) "$$f" || exit; done for f in examples/*.janet; do $(CALLGRIND_COMMAND) ./$(JANET_TARGET) -k "$$f"; done ######################## ##### Distribution ##### ######################## dist: build/janet-dist.tar.gz build/janet-%.tar.gz: $(JANET_TARGET) \ build/janet.h \ janet.1 LICENSE CONTRIBUTING.md $(JANET_STATIC_LIBRARY) \ README.md build/c/janet.c build/c/shell.c mkdir -p build/$(JANET_DIST_DIR)/bin cp $(JANET_TARGET) build/$(JANET_DIST_DIR)/bin/ strip $(STRIPFLAGS) 'build/$(JANET_DIST_DIR)/bin/janet' mkdir -p build/$(JANET_DIST_DIR)/include cp build/janet.h build/$(JANET_DIST_DIR)/include/ mkdir -p build/$(JANET_DIST_DIR)/lib/ cp $(JANET_STATIC_LIBRARY) build/$(JANET_DIST_DIR)/lib/ cp $(JANET_LIBRARY) build/$(JANET_DIST_DIR)/lib/ || true mkdir -p build/$(JANET_DIST_DIR)/man/man1/ cp janet.1 build/$(JANET_DIST_DIR)/man/man1/janet.1 mkdir -p build/$(JANET_DIST_DIR)/src/ cp build/c/janet.c build/c/shell.c build/$(JANET_DIST_DIR)/src/ cp CONTRIBUTING.md LICENSE README.md build/$(JANET_DIST_DIR)/ cd build && tar -czvf ../$@ ./$(JANET_DIST_DIR) ifeq ($(HAS_SHARED), 1) build/janet-%.tar.gz: $(JANET_LIBRARY) endif ######################### ##### Documentation ##### ######################### docs: build/doc.html build/doc.html: $(JANET_TARGET) tools/gendoc.janet $(RUN) $(JANET_TARGET) tools/gendoc.janet > build/doc.html ######################## ##### Installation ##### ######################## .INTERMEDIATE: build/janet.pc build/janet.pc: $(JANET_TARGET) echo 'prefix=$(PREFIX)' > $@ echo 'exec_prefix=$${prefix}' >> $@ echo 'includedir=$(INCLUDEDIR)/janet' >> $@ echo 'libdir=$(LIBDIR)' >> $@ echo "" >> $@ echo "Name: janet" >> $@ echo "Url: https://janet-lang.org" >> $@ echo "Description: Library for the Janet programming language." >> $@ $(RUN) $(JANET_TARGET) -e '(print "Version: " janet/version)' >> $@ echo 'Cflags: -I$${includedir}' >> $@ echo 'Libs: -L$${libdir} -ljanet' >> $@ echo 'Libs.private: $(CLIBS)' >> $@ install: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.pc build/janet.h $(eval JANET_VERSION := $(shell $(JANET_TARGET) -e '(print janet/version)')) mkdir -p '$(DESTDIR)$(BINDIR)' cp $(JANET_TARGET) '$(DESTDIR)$(BINDIR)/janet' strip $(STRIPFLAGS) '$(DESTDIR)$(BINDIR)/janet' mkdir -p '$(DESTDIR)$(INCLUDEDIR)/janet' cp -r build/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet' ln -sf ./janet/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet.h' mkdir -p '$(DESTDIR)$(JANET_PATH)' mkdir -p '$(DESTDIR)$(LIBDIR)' if test $(UNAME) = Darwin ; then \ cp $(JANET_LIBRARY) '$(DESTDIR)$(LIBDIR)/libjanet.$(JANET_VERSION).dylib' ; \ ln -sf $(SONAME) '$(DESTDIR)$(LIBDIR)/libjanet.dylib' ; \ ln -sf libjanet.$(JANET_VERSION).dylib $(DESTDIR)$(LIBDIR)/$(SONAME) ; \ else \ cp $(JANET_LIBRARY) '$(DESTDIR)$(LIBDIR)/libjanet.so.$(JANET_VERSION)' ; \ ln -sf $(SONAME) '$(DESTDIR)$(LIBDIR)/libjanet.so' ; \ ln -sf libjanet.so.$(JANET_VERSION) $(DESTDIR)$(LIBDIR)/$(SONAME) ; \ fi cp $(JANET_STATIC_LIBRARY) '$(DESTDIR)$(LIBDIR)/libjanet.a' mkdir -p '$(DESTDIR)$(JANET_MANPATH)' cp janet.1 '$(DESTDIR)$(JANET_MANPATH)' mkdir -p '$(DESTDIR)$(JANET_PKG_CONFIG_PATH)' cp build/janet.pc '$(DESTDIR)$(JANET_PKG_CONFIG_PATH)/janet.pc' cp '$(JANET_IMPORT_LIB)' '$(DESTDIR)$(LIBDIR)' || echo 'no import lib to install (mingw only)' cp '$(JANET_LIBRARY_IMPORT_LIB)' '$(DESTDIR)$(LIBDIR)' || echo 'no import lib to install (mingw only)' [ -z '$(DESTDIR)' ] && $(LDCONFIG) || echo "You can ignore this error for non-Linux systems or local installs" install-jpm-git: $(JANET_TARGET) mkdir -p build rm -rf build/jpm git clone --depth=1 --branch='$(JPM_TAG)' https://github.com/janet-lang/jpm.git build/jpm cd build/jpm && PREFIX='$(PREFIX)' \ DESTDIR=$(DESTDIR) \ JANET_MANPATH='$(JANET_MANPATH)' \ JANET_HEADERPATH='$(INCLUDEDIR)/janet' \ JANET_BINPATH='$(BINDIR)' \ JANET_LIBPATH='$(LIBDIR)' \ $(RUN) ../../$(JANET_TARGET) ./bootstrap.janet install-spork-git: $(JANET_TARGET) mkdir -p build rm -rf build/spork git clone --depth=1 --branch='$(SPORK_TAG)' https://github.com/janet-lang/spork.git build/spork $(JANET_TARGET) -e '(bundle/install "build/spork")' uninstall: -rm '$(DESTDIR)$(BINDIR)/janet' -rm -rf '$(DESTDIR)$(INCLUDEDIR)/janet' -rm -rf '$(DESTDIR)$(INCLUDEDIR)/janet.h' -rm -rf '$(DESTDIR)$(LIBDIR)'/libjanet.* -rm '$(DESTDIR)$(JANET_PKG_CONFIG_PATH)/janet.pc' -rm '$(DESTDIR)$(JANET_MANPATH)/janet.1' # -rm -rf '$(DESTDIR)$(JANET_PATH)'/* - err on the side of correctness here ################# ##### Other ##### ################# format: sh tools/format.sh grammar: build/janet.tmLanguage build/janet.tmLanguage: tools/tm_lang_gen.janet $(JANET_TARGET) $(RUN) $(JANET_TARGET) $< > $@ compile-commands: # Requires pip install compiledb compiledb make clean: -rm -rf build vgcore.* callgrind.* -rm -rf test/install/build test/install/modpath help: @echo @echo 'Janet: A Dynamic Language & Bytecode VM' @echo @echo Usage: @echo ' make Build Janet' @echo ' make repl Start a REPL from a built Janet' @echo @echo ' make test Test a built Janet' @echo ' make valgrind Assess Janet with Valgrind' @echo ' make callgrind Assess Janet with Valgrind, using Callgrind' @echo ' make valtest Run the test suite and examples with Valgrind to check for memory leaks' @echo ' make calltest Run the test suite and examples with Callgrind' @echo ' make dist Create a distribution tarball' @echo ' make docs Generate documentation' @echo ' make debug Run janet with GDB or LLDB' @echo ' make install Install into the current filesystem' @echo ' make uninstall Uninstall from the current filesystem' @echo ' make clean Clean intermediate build artifacts' @echo " make format Format Janet's own source files" @echo ' make grammar Generate a TextMate language grammar' @echo @echo ' make install-jpm-git Install jpm into the current filesystem' @echo ' make install-spork-git Install spork into the current filesystem' @echo .PHONY: clean install install-jpm-git install-spork-git repl debug valgrind test \ valtest callgrind callgrind-test dist uninstall docs grammar format help compile-commands janet-1.41.2/README.md000066400000000000000000000426211514534607600141770ustar00rootroot00000000000000[![Join the chat](https://img.shields.io/badge/zulip-join_chat-brightgreen.svg)](https://janet.zulipchat.com)   [![builds.sr.ht status](https://builds.sr.ht/~bakpakin/janet/commits/master/freebsd.yml.svg)](https://builds.sr.ht/~bakpakin/janet/commits/master/freebsd.yml?) [![builds.sr.ht status](https://builds.sr.ht/~bakpakin/janet/commits/master/openbsd.yml.svg)](https://builds.sr.ht/~bakpakin/janet/commits/master/openbsd.yml?) [![Actions Status](https://github.com/janet-lang/janet/actions/workflows/test.yml/badge.svg)](https://github.com/janet-lang/janet/actions/workflows/test.yml) Janet logo **Janet** is a programming language for system scripting, expressive automation, and extending programs written in C or C++ with user scripting capabilities. Janet makes a good system scripting language, or a language to embed in other programs. It's like Lua and GNU Guile in that regard. It has more built-in functionality and a richer core language than Lua, but smaller than GNU Guile or Python. However, it is much easier to embed and port than Python or Guile. There is a REPL for trying out the language, as well as the ability to run script files. This client program is separate from the core runtime, so Janet can be embedded in other programs. Try Janet in your browser at .
## Examples See the examples directory for all provided example programs. ### Game of Life ```janet # John Conway's Game of Life (def- window (seq [x :range [-1 2] y :range [-1 2] :when (not (and (zero? x) (zero? y)))] [x y])) (defn- neighbors [[x y]] (map (fn [[x1 y1]] [(+ x x1) (+ y y1)]) window)) (defn tick "Get the next state in the Game Of Life." [state] (def cell-set (frequencies state)) (def neighbor-set (frequencies (mapcat neighbors state))) (seq [coord :keys neighbor-set :let [count (get neighbor-set coord)] :when (or (= count 3) (and (get cell-set coord) (= count 2)))] coord)) (defn draw "Draw cells in the game of life from (x1, y1) to (x2, y2)" [state x1 y1 x2 y2] (def cellset @{}) (each cell state (put cellset cell true)) (loop [x :range [x1 (+ 1 x2)] :after (print) y :range [y1 (+ 1 y2)]] (file/write stdout (if (get cellset [x y]) "X " ". "))) (print)) # Print the first 20 generations of a glider (var *state* '[(0 0) (-1 0) (1 0) (1 1) (0 2)]) (for i 0 20 (print "generation " i) (draw *state* -7 -7 7 7) (set *state* (tick *state*))) ``` ### TCP Echo Server ```janet # A simple TCP echo server using the built-in socket networking and event loop. (defn handler "Simple handler for connections." [stream] (defer (:close stream) (def id (gensym)) (def b @"") (print "Connection " id "!") (while (:read stream 1024 b) (printf " %v -> %v" id b) (:write stream b) (buffer/clear b)) (printf "Done %v!" id) (ev/sleep 0.5))) (net/server "127.0.0.1" "8000" handler) ``` ### Windows FFI Hello, World! ```janet # Use the FFI to popup a Windows message box - no C required (ffi/context "user32.dll") (ffi/defbind MessageBoxA :int [w :ptr text :string cap :string typ :int]) (MessageBoxA nil "Hello, World!" "Test" 0) ``` ## Language Features * 600+ functions and macros in the core library * Built-in socket networking, threading, subprocesses, and file system functions. * Parsing Expression Grammars (PEG) engine as a more robust Regex alternative * Macros and compile-time computation * Per-thread event loop for efficient IO (epoll/IOCP/kqueue) * First-class green threads (continuations) as well as OS threads * Erlang-style supervision trees that integrate with the event loop * First-class closures * Garbage collection * Distributed as janet.c and janet.h for embedding into a larger program. * Python-style generators (implemented as a plain macro) * Mutable and immutable arrays (array/tuple) * Mutable and immutable hashtables (table/struct) * Mutable and immutable strings (buffer/string) * Tail recursion * Interface with C functions and dynamically load plugins ("natives"). * Built-in C FFI for when the native bindings are too much work * REPL development with debugger and inspectable runtime ## Documentation * For a quick tutorial, see [the introduction](https://janet-lang.org/docs/index.html) for more details. * For the full API for all functions in the core library, see [the core API doc](https://janet-lang.org/api/index.html). Documentation is also available locally in the REPL. Use the `(doc symbol-name)` macro to get API documentation for symbols in the core library. For example, ``` (doc apply) ``` shows documentation for the `apply` function. To get a list of all bindings in the default environment, use the `(all-bindings)` function. You can also use the `(doc)` macro with no arguments if you are in the REPL to show bound symbols. ## Source You can get the source on [GitHub](https://github.com/janet-lang/janet) or [SourceHut](https://git.sr.ht/~bakpakin/janet). While the GitHub repo is the official repo, the SourceHut mirror is actively maintained. ## Spork and JPM Spork and JPM are two companion projects to Janet. They are optional, especially in an embedding use case. Spork is a collection of common utility modules, and several packaged scripts like `janet-format` for code formatting, `janet-netrepl` for a socket-based REPL, and `janet-pm` for a comprehensive Janet project manager tool. The modules in `spork` are less stable than the interfaces in core Janet, although we try to prevent breaking changes to existing modules, with a preference to add new modules and functions. Spork requires a C compiler to build and install various extenstion components such as miniz and JSON utilities. Many spork sub-modules, for example spork/path, are independent and can be manually vendored in programmer projects without fully installing spork. When install Spork, scripts will be installed to $JANET_PATH/bin/ on POSIX systems by default. This likely needs to be added to the path to use these scripts. JPM is the older, more opinionated, project manager tool, which has it's pros and cons. It does not require a C compiler to build and install, but is less flexible and is not receiving many changes and improvements going forward. It may also be harder to configure correctly on new systems. In that sense, it may be more stable. JPM will install to /usr/local/bin/ on posix systems by default, which may or may not be on your PATH. ## Building When building from source, for stability, please use the latest tagged release. For example, run `git checkout $(git describe --tags --abbrev=0)` after cloning but before building. For the latest development, build directly on the master branch. The master branch is not-necessarily stable as most Janet development happens directly on the master branch. ### macOS and Unix-like The Makefile is non-portable and requires GNU-flavored make. ```sh cd somewhere/my/projects/janet make make test make repl make install make install-spork-git # optional make install-jpm-git # optional ``` Find out more about the available make targets by running `make help`. ### Alpine Linux To build a statically-linked build of Janet, Alpine Linux + MUSL is a good combination. Janet can also be built inside a docker container or similar in this manner. This is a great way to try Janet without committing to a full install or needing to customize the default install. ```sh docker run -it --rm alpine /bin/ash $ apk add make gcc musl-dev git $ git clone https://github.com/janet-lang/janet.git $ cd janet $ make -j10 $ make test $ make install $ make install-spork-git # optional $ make install-jpm-git # optional ``` Note that for a true statically-linked binary with MUSL, one needs to add `-static` to the Makefile flags. This will also disable runtime loading of native modules (plugins) as well as the FFI. ### 32-bit Haiku 32-bit Haiku build instructions are the same as the UNIX-like build instructions, but you need to specify an alternative compiler, such as `gcc-x86`. ```sh cd somewhere/my/projects/janet make CC=gcc-x86 make test make repl make install make install-spork-git # optional make install-jpm-git # optional ``` ### FreeBSD FreeBSD build instructions are the same as the UNIX-like build instructions, but you need `gmake` to compile. Alternatively, install the package directly with `pkg install lang/janet`. ```sh cd somewhere/my/projects/janet gmake gmake test gmake repl gmake install gmake install-spork-git # optional gmake install-jpm-git # optional ``` ### NetBSD NetBSD build instructions are the same as the FreeBSD build instructions. Alternatively, install the package directly with `pkgin install janet`. ### illumos Building on illumos is exactly the same as building on FreeBSD. ### Windows 1. Install [Visual Studio](https://visualstudio.microsoft.com/thank-you-downloading-visual-studio/?sku=Community&rel=15#) or [Visual Studio Build Tools](https://visualstudio.microsoft.com/thank-you-downloading-visual-studio/?sku=BuildTools&rel=15#). 2. Run a Visual Studio Command Prompt (`cl.exe` and `link.exe` need to be on your PATH) and `cd` to the directory with Janet. 3. Run `build_win` to compile Janet. 4. Run `build_win test` to make sure everything is working. To build an `.msi` installer executable, in addition to the above steps, you will have to: 5. Install, or otherwise add to your PATH the [WiX 3.14 Toolset](https://github.com/wixtoolset/wix3/releases). 6. Run `build_win dist`. Now you should have an `.msi`. You can run `build_win install` to install the `.msi`, or execute the file itself. ### Meson Janet also has a build file for [Meson](https://mesonbuild.com/), a cross-platform build system. Although Meson has a Python dependency, Meson is a very complete build system that is maybe more convenient and flexible for integrating into existing pipelines. Meson also provides much better IDE integration than Make or batch files, as well as support for cross-compilation. For the impatient, building with Meson is as follows. The options provided to `meson setup` below emulate Janet's Makefile. ```sh git clone https://github.com/janet-lang/janet.git cd janet meson setup build \ --buildtype release \ --optimization 2 \ --libdir /usr/local/lib \ -Dgit_hash=$(git log --pretty=format:'%h' -n 1) ninja -C build # Run the binary build/janet # Installation ninja -C build install ``` ## Development Janet can be hacked on with pretty much any environment you like, but for IDE lovers, [Gnome Builder](https://wiki.gnome.org/Apps/Builder) is probably the best option, as it has excellent Meson integration. It also offers code completion for Janet's C API right out of the box, which is very useful for exploring. VSCode, Vim, Emacs, and Atom each have syntax packages for the Janet language, though. ## Installation If you just want to try out the language, you don't need to install anything. In this case you can also move the `janet` executable wherever you want on your system and run it. However, for a fuller setup, please see the [Introduction](https://janet-lang.org/docs/index.html) for more details. ## Usage A REPL is launched when the binary is invoked with no arguments. Pass the `-h` flag to display the usage information. Individual scripts can be run with `./janet myscript.janet`. If you are looking to explore, you can print a list of all available macros, functions, and constants by entering the command `(all-bindings)` into the REPL. ``` $ janet Janet 1.7.1-dev-951e10f Copyright (C) 2017-2020 Calvin Rose janet:1:> (+ 1 2 3) 6 janet:2:> (print "Hello, World!") Hello, World! nil janet:3:> (os/exit) $ janet -h usage: janet [options] script args... Options are: -h : Show this help -v : Print the version string -s : Use raw stdin instead of getline like functionality -e code : Execute a string of janet -E code arguments... : Evaluate an expression as a short-fn with arguments -d : Set the debug flag in the REPL -r : Enter the REPL after running all scripts -R : Disables loading profile.janet when JANET_PROFILE is present -p : Keep on executing if there is a top-level error (persistent) -q : Hide logo (quiet) -k : Compile scripts but do not execute (flycheck) -m syspath : Set system path for loading global modules -c source output : Compile janet source code into an image -i : Load the script argument as an image file instead of source code -n : Disable ANSI color output in the REPL -l lib : Use a module before processing more arguments -w level : Set the lint warning level - default is "normal" -x level : Set the lint error level - default is "none" -- : Stop handling options ``` If installed, you can also run `man janet` to get usage information. ## Embedding Janet can be embedded in a host program very easily. The normal build will create a file `build/c/janet.c`, a C source code file that that contains the amalgamated source to Janet. This file, along with `src/include/janet.h` and `src/conf/janetconf.h`, can be dragged into any C project and compiled into it. Janet should be compiled with `-std=c99` on most compilers, and will need to be linked to the math library, `-lm`, and the dynamic linker, `-ldl`, if one wants to be able to load dynamic modules. If there is no need for dynamic modules, add the define `-DJANET_NO_DYNAMIC_MODULES` to the compiler options. See the [Embedding Section](https://janet-lang.org/capi/embedding.html) on the website for more information. ## Discussion Feel free to ask questions and join the discussion on the [Janet Zulip Instance](https://janet.zulipchat.com/) ## FAQ ### How fast is it? It is about the same speed as most interpreted languages without a JIT compiler. Tight, critical loops should probably be written in C or C++ . Programs tend to be a bit faster than they would be in a language like Python due to the discouragement of slow Object-Oriented abstraction with lots of hash-table lookups, and making late-binding explicit. All values are boxed in an 8-byte representation by default and allocated on the heap, with the exception of numbers, nils and booleans. The PEG engine is a specialized interpreter that can efficiently process string and buffer data. The GC is simple and stop-the-world, but GC knobs are exposed in the core library and separate threads have isolated heaps and garbage collectors. Data that is shared between threads is reference counted. YMMV. ### Where is (favorite feature from other language)? It may exist, it may not. If you want to propose a major language feature, go ahead and open an issue, but it will likely be closed as "will not implement". Often, such features make one usecase simpler at the expense of 5 others by making the language more complicated. ### Is there a language spec? There is not currently a spec besides the documentation at . ### Is this Scheme/Common Lisp? Where are the cons cells? Nope. There are no cons cells here. ### Is this a Clojure port? No. It's similar to Clojure superficially because I like Lisps and I like the aesthetics. Internally, Janet is not at all like Clojure, Scheme, or Common Lisp. ### Are the immutable data structures (tuples and structs) implemented as hash tries? No. They are immutable arrays and hash tables. Don't try and use them like Clojure's vectors and maps, instead they work well as table keys or other identifiers. ### Can I do object-oriented programming with Janet? To some extent, yes. However, it is not the recommended method of abstraction, and performance may suffer. That said, tables can be used to make mutable objects with inheritance and polymorphism, where object methods are implemented with keywords. ```clj (def Car @{:honk (fn [self msg] (print "car " self " goes " msg)) }) (def my-car (table/setproto @{} Car)) (:honk my-car "Beep!") ``` ### Why can't we add (feature from Clojure) into the core? Usually, one of a few reasons: - Often, it already exists in a different form and the Clojure port would be redundant. - Clojure programs often generate a lot of garbage and rely on the JVM to clean it up. Janet does not run on the JVM and has a more primitive garbage collector. - We want to keep the Janet core small. With Lisps, a feature can usually be added as a library without feeling "bolted on", especially when compared to ALGOL-like languages. Adding features to the core also makes it a bit more difficult to keep Janet maximally portable. ### Can I bind to Rust/Zig/Go/Java/Nim/C++/D/Pascal/Fortran/Odin/Jai/(Some new "Systems" Programming Language)? Probably, if that language has a good interface with C. But the programmer may need to do some extra work to map Janet's internal memory model to that of the bound language. Janet also uses `setjmp`/`longjmp` for non-local returns internally. This approach is out of favor with many programmers now and doesn't always play well with other languages that have exceptions or stack-unwinding. ### Why is my terminal spitting out junk when I run the REPL? Make sure your terminal supports ANSI escape codes. Most modern terminals will support these, but some older terminals, Windows consoles, or embedded terminals will not. If your terminal does not support ANSI escape codes, run the REPL with the `-n` flag, which disables color output. You can also try the `-s` flag if further issues ensue. ## Why is it called "Janet"? Janet is named after the almost omniscient and friendly artificial being in [The Good Place](https://en.wikipedia.org/wiki/The_Good_Place). janet-1.41.2/assets/000077500000000000000000000000001514534607600142155ustar00rootroot00000000000000janet-1.41.2/assets/icon.ico000066400000000000000000003073661514534607600156600ustar00rootroot00000000000000 hf   V00 %@@ (BD (Ά(  %s \rDtSUUUU^@gܵgWUUԍUAU UUP8(nRUUUUUԕUUUSvDYVXUUUUSU ] ZEbQ[aTUU_Uyyևs_TUUHU+ꇪ0sTUUU6UUOlte/sVUUUU1UURS i퀦i!j ]YTUUUUU/UUUԫXIeeSTUUUUUUUUVUԆUWYUUUUUUUUUԋTUUUUԳUUUUUUUUUUU!UUUUUԻUUUUUUUUU9UUUUU/UUUUUUUԞU,UUUUU'U:U9U8U)UUU(0 N6ޟެއMR UU TTUWP!Eـ⇪g֫TUUԐUMURTTUR5cn|fTUUUUUxUUTUUS:zk ZUUUUUUUԪUUUUAV[q ]TTTUUUUUdUTUS7 ]o6wW'naUUUUUԛTT8 *oף}}a~UVUUUU~UT^MUUUUUcUtdTUUUUVUޣ}-qTUUUUU=UU9y0s}ʇq-qUUUUUUU=UUR [եifG:y*p_TUUUUUUU=UUUUԘW[R [TTTTUUUUUUUU9UUU&UT#kv\ \TUUUUUUUUUUUUUUU,UUUf2u ]TUUUUUUUUUUUUԩTUUUUԦUUTTUUUUUUUUUUUUUUGUUUU(UUUUUUUUUUUUUUUUUԑUUUUU-UUUUUUUUUUUUUUUԶUUTUU1UUUUUUUUUUUUUԷU UUUUUOUUUUUUUUUUUԌUUUUUUjUԪUԨUԨUԨUԨUԏUUnU1UUUUUUUUSSR??( @ F}{Շ݇޼ޚSiTUU TTSOH gLsܶOuTUUUԎUSUTTUUS#XԬORUUUUUUUԖUBT UUU"SԽ'm-rTUUUUUUUUԡU!UUTRUԔUR~fTUUUUUUUUUԸUUUUT \n"jTUUUUUUUUUUqUUUUTf~DTTXXUUUUUUUԻT TUUSԫ/sy.r^MQ ZUUUUUUT TSWR=O䈫r,qTUUUUUԛMTmd޸"jTUUUUUUՇYXUUUUUU~U*自sdTUUUUUUXUHz(nTUUUUUUUIUUzkr)oUUUUUUUUUIUUUPBF݇~tl_CbTUUUUUUUUUIUTWUBS;zEf^ [WTTUUUUUUUUUUIUUU"UT(n7xUTTUUUUUUUUUUUUUUDUUUcUUYVEVUUUUUUUUUUUUUUUUU#UUUUUT \IkA~YUUUUUUUUUUUUUUUUUԼT UUU_UUUUVZUUUUUUUUUUUUUUUUUUUfUTUUUԾUUUUUUUUUUUUUUUUUUUUUUUUUSUU<UUUUUUUUUUUUUUUUUUUUUUUOUTUUUBUUUUUUUUUUUUUUUUUUUUUUUUTUBUUUUUUUUUUUUUUUUUUUԕUUTVUPUUUUUUUUUUUUUUUUUԕTTUUUtUUUUUUUUUUUUUUUoT TUU UԢUUUUUUUUUUUUԉU2RTUUUHUHUHUHUHUHUIU3UUTUU?(0` $7|ށX0$ޒ뇪ᇪި`#8xUUUT TJC -pLzݶ㉫r_.UԦUUUԸUԋUMU%TUTT SL_ճ[@}TUUUUUUUԨU`U#UUUU UԊXM<{TUUUUUUUUUUԏTGT TUU UԊT(ovaTUUUUUUUUUUUUԠU(UUTOUԀUWX`XUUUUUUUUUUUUUUU9USUU$UTawXWUUUUUUUUUUUUUUUUUUUaUT-q_XUUUUUUUUUUUUUUUUԎUUUUUTFr^TUUUUUUUUUUUUUUUUUUUvUW^5vTUUV [UUUUUUUUUUUUPUUU7T^rqgTS+pi.rVUUUUUUUUUUPUTT Sӱg}uE7wq{#kTUUUUUUUUT0TTUM*<{ЅGUUUUUUUUUTT}ݜ5vTUUUUUUUUԷUUީsaTUUUUUUUUԷUUއ;zUUUUUUUUUUԷST!䇪ZZUUUUUUUUUUԃWTVmbTUUUUUUUUUUcUcq iTUUUUUUUUUUUcU{n iTUUUUUUUUUUUUcUUZY*iֈWcTUUUUUUUUUUUUUcUUU)VU~ulcVA~ iXTUUUUUUUUUUUUUUcUUUU)UVVi7xg_ [YVTTUUUUUUUUUUUUUUUUcUTT'UUUM[_TTTUUUUUUUUUUUUUUUUUUUUUcUUUUԚUUT.ra^TUUUUUUUUUUUUUUUUUUUUUUUU[UUUUUUU []ndTUUUUUUUUUUUUUUUUUUUUUUUUU%UUUGUUUUTa`s"jTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUHUUUUUT ]CgVfTUUUUUUUUUUUUUUUUUUUUUUUUUUԗ`TUU8UUUUUUTUZWTUUUUUUUUUUUUUUUUUUUUUUUUUUUAUUUUԧUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUԧUUUU5UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUBUUUUnUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUԆTTUUUuUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUԵUUUUUuUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU4UUUUuUUUUUUUUUUUUUUUUUUUUUUUUUUUUUKYTTSUuUUUUUUUUUUUUUUUUUUUUUUUUUUTKUUUU UԩUUUUUUUUUUUUUUUUUUUUUUUUUK[TUUUԸUUUUUUUUUUUUUUUUUUUUUUԷT;QTUUU;UUUUUUUUUUUUUUUUUUUUUwTUSUUU]UUUUUUUUUUUUUUUUU԰UhU)UUUU UUUdUcUcUcUcUcUcUcUcTdUOUUUTTT!?????(@ @ L޳凪䇪؇ފu' ަ自޲s' UUTUUTTRD ?|Lݶ釪ާPUԀUUUUԱUUNUUUUU RLdֳb޲eֲTUUUUUUUUԲUsU'T TUVTITԳ^\:yTUUUUUUUUUUUԲUsU$UUUUUUUXN~#kTUUUUUUUUUUUUUUԌTMT TUUUUUT)o^YUUUUUUUUUUUUUUUUUӦU"UUTJUUUUX[<{TUUUUUUUUUUUUUUUUUUUUJTTT#UUTf{,pTUUUUUUUUUUUUUUUUUUUUULTUUuUUT:y)nTUUUUUUUUUUUUUUUUUUUUU#UTT UԱUUWW/rTUUUUUUUUUUUUUUUUUUUUUԦU UUUUUT ]pA~TUUUUUUUUUUUUUUUUUUUUUU'UUUUUTg}`YUUUUUUUUUUUUUUUUUUUUUUuUUUUUT3u(nTUUUUZYUUUUUUUUUUUUUUUԳT TUUUԊUUJgaTUT_^XaUUUUUUUUUUUUUUԳT TTTNTY^e'n [ \Oc`TUUUUUUUUUUUUUTT TԦ ]qggFUUUUUUUUUUUUTuTUJ+p׵|]XUUUUUUUUUUUU'UyuIUUUUUUUUUUUUUU&mTUUUUUUUUUUUUU ޱ[YUUUUUUUUUUUUTU㇪x iTUUUUUUUUUUUUTT㇪=|VUUUUUUUUUUUUUԱT TNUYUUUUUUUUUUUUUUUd`TUUUUUUUUUUUUUUUgdTUUUUUUUUUUUUUUUU{ފfdTUUUUUUUUUUUUUUUUUfR#܇WaTUUUUUUUUUUUUUUUUUUUP_ժl~f4vYTUUUUUUUUUUUUUUUUUUUUUTԪ \k}wlcXK;z!j [UUUUUUUUUUUUUUUUUUUUUUUUUԪU \kY3uh_ \ZXUTTUUUUUUUUUUUUUUUUUUUUUUUUTUԪUU [gv/sXTTTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTT UԦUUUWWw)oUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUNUUUUT4v~0sUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTuTTXUԊUUUUU \bA~VUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU'UUTUUUUUUTflNYUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTd`M \TUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUԱT TUUUUUUUUUUT \<{`]3uYTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUuUUTUUUUUUUUUTUYXTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU#UTYUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU#UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU#UU[UYUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUXTUU UԦUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUԵTUUUUԪUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUJUUUUԪUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUY[UUUUԪUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUԦU UUUUԪUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUԪTUTTUԪUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUԪTTUUUԵUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUԪTTUUJUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUԪTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUԶTIRTUUUԪUUUUUUUUUUUUUUUUUUUUUUUUUUԀTUUU#UUUUUUUUUUUUUUUUUUUUUUUԌUMUUUUUUKUԂUUUUUUUUUUUUTԀUuU'UUUUTTT0????????????( UTUUUUT.rTUUUUUUUUUUUTUeUUUUUUUUUUUUUUUUTUTUe,pUUUUUUUUUUUUUUUUUUUUTUUUevUUUUUUUUUUUUUUUUUUUUUUUTTUUU_~UUUUUUUUUUUUUUUUUUUUUUUUUTUUUUU[nTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUL_UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTTUUUUU"k]UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUe*oUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU"k~UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTeUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUU[LUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUU3uDUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUU]DUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUDUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU"kDUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUD]UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUenUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU[UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUe3uUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU3u]UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUL_UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUneUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUU3uUUUUUUUUUU3ueeUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUU"keUUUUUUUUeeUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUU;{*oUUUUUUUn3uUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUL]eUUUUTeUUUUUUUUUUUUUUUUUUUUUUUUUTTUUUenDDevUUUUUUUUUUUUUUUUUUUUUUUUUTUUU*oUUUUUUUUUUUUUUUUUUUUUUUUTUeDUUUUUUUUUUUUUUUUUUUUUUUU3uDUUUUUUUUUUUUUUUUUUUUUUUUc"kUUUUUUUUUUUUUUUUUUUUUUUU~UUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUU"kUUUUUUUUUUUUUUUUUUUUUUUUUeUUUUUUUUUUUUUUUUUUUUUUUUUUeUUUUUUUUUUUUUUUUUUUUUUUUUTLUUUUUUUUUUUUUUUUUUUUUUUUUUTv[UUUUUUUUUUUUUUUUUUUUUUUUUUT"kUUUUUUUUUUUUUUUUUUUUUUUUUUUTDUUUUUUUUUUUUUUUUUUUUUUUUUUUUeUUUUUUUUUUUUUUUUUUUUUUUUUUUUU~[UUUUUUUUUUUUUUUUUUUUUUUUUUUUU~eUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU3uUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU3uUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU3uUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU3uUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU3uUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU~"kUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUre_UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTe~;zUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUevC[UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUe~eCeUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUeee\CC*p!j[UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUemK2t!jUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUeTeUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUem"kUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTm[UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUDm[UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUU"km[UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU~~[UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUD~eUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUU[~3uUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU*oLUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUDTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUKmUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU3um[UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUU"k~TUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU[T~;zUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU_CTT2t[UUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUTTUUUUUUUUUUUUUUUUUUUUUUUUUUTTTTU?????????????????????janet-1.41.2/assets/icon_svg.svg000066400000000000000000000023201514534607600165420ustar00rootroot00000000000000 janet-1.41.2/assets/janet-big.png000066400000000000000000001741111514534607600165700ustar00rootroot00000000000000PNG  IHDR sBIT|d pHYs++z>YtEXtSoftwarewww.inkscape.org< IDATxwdUVܓz"93d5k^ouq]DD% L`rΕ8LLsު>OtwNW}F`>ON2t`щf-@3@F $ā;h;{9`? I$~$}XGbG`0F-0yLF0Ƣy\]L @)Z"v;6laM#n i0Lg`08Mcq8Cp8Ñ,B)n$!Yuجep[81'dcs,cccZ9!Y(>xڄ =P ,y.K5]J`VqLCa a2VFR,CrpjQv[,lC# '5 Q`8',^tt8͚7x,'WN]`0VY؜\bc)(n d01 ӏd+!GL~ xdx3D Vc!8x-7HX~|:FQp[(I`Ozdk娆:CBrLOC=b CMˁˀW!w2 /61` Cm󄜃7W2-%2?! ,`(cjPJTn'ϭ&-0̍P8\\I3x xTm 0 -P)$wc+$T` cǓ| omv?e 1<$4q)XEma s5Jy46Dv 8JP@A ,~ʣVi[BxmI6$l}C |b/0T[E\VTƼ!(q -5U 2F 76 䡯ؓWo8OH~g:Ǔ u[7  C_)v?|=1P4=yؑ9ؕ16?$9A-az` 󨤾Qũ&> ¬(Eo>| [*`ggaKdՕݖ # )bs28ry6>>Cf`A`^}o(26eaCF];s0 9&$_gxma 1 zbcK):pD)??6qCʆE`]^LB"n c/`CO|8mqt(GJ?lN^kB^L]Ybma -D,91gwEl O/C"Y K-n bpsȣ-DUo AVF0ag<&[ esp yP +ۑn bpc+=2z9KpAL3 p  y/YmA 1zdPMg.y Agz+ap'D [q=#ہ(# -EI3& U~oaZHp =[rR^,EC h Q oUa7OLۂ*ܚk'd n*Eq Ix`Wv|n1E2k(aTPd$aW {mI* mA a ZDo xb`0xIerb@pa>beI ` R.Arp["fo0x|b^Hxx3K*W0L{)+0p=}I_P3׽Ww||!Q`8cx'd7 -U؈[ Jy6[Ͽ401 y$;>jZ1` R Rß8YuM![X!/Dk\?9 m7y z? +0,w&TWpOomSuy< FKzip{4nZ6nl$ u@ic0Lހ'FwrpO1\G.qu`R})3H*:n- 0`'g{]2 +X&6\m@G>z8$$ pRH"O ]_ٗu` H!`)a uh>5aHp>xН^$WLѕݧ9p׀\K r`r0S~)az83| WTK74!CO֧4ۡ}YؓY؛ޜ:Fh 4Q?4!a0*ݫ!g(U.Or \Rm ū(HؕiY<0l&W_iCPqÂFcT'e~FrF5v |*f}e %XaB +kP)$!KNpAX"1x΂e^@շހ L@gzOeXtVk˨qyxnH)锰w0NG|*!#\^@BR!Cv }ȿh`;׾!? i9HP+`:@BZ죠cA^.'Tnpu?:0葯nVix> j8_)pYQ%ع^]{7.ا 6A9 5hH>sEKabe4*fo֤mxKŽUu` 'X)C}*]-o74{`O^>xvP}]OD}xb)\;W MCap)pp쫠}R, }o#yϫmuQ_H)X-#|#׽^%+?`j,ly=]P" !p9pZn{Ryյi/KſUu:P}Z[v_`.jlw t-|K@7J6+aCk1( aEp#(9~'lGA]a3HH杮 |Z[.‡:Uҟ ݪq XVT!<%x1xqxQu/]mpഫӍ10 )G% V!UywWʭB~\SpY3/ގ4ܿc!PJ~Ff⏏&638墨6|3N\h j^:uHMs_ y{5XuaV?8kdZ3~TWNCmrkA#4'gU1/ Yy1NZfT ]>P~A5>cKÚGa]}Mu4&e\a>mi< yoe0I9e` rX-$ 뫱Qp'45s?+ G6mJٯWhP+)!Ε.<=0UN\kSsoO?xjkljf2F^܆R-pU;Mv*h ‰q8a;_c*`pM.7E_Zrd3qyJ" ɹNox~H5!8Y&)3xN7ń<2 S|aH.7K#ENo]pڗ' pV (sxqO!U t\-uے|}W*cLNoOπ!w"U"dIp|.|rmxo9,e˪֟O y4-lWv¾j8$%4A:9)9UwP)9u:Aw8o7@ C +{Ո1 PrfluUYpͷଷTa3WM٪lCN51&G~ Q5(;V8zTS5}߁ Ze&K Y{ULA}>BxckU#UOVa#?|mhv?ϑHAxm+mX~uX} 1₷{-!/^i+He ūn]V $nx:>RTcLwd"9}jT}rezg^kgejkp KW~ ,ޱzYB}+F}= uAaH!Y~3Vc~v~D>8SU+ 85MwliOib*m[{E^T#R{DW9j(nr 1FwAM"TWe,q'%Vw!< yy]' 3 uk:- Ee+jcKT)^/\Vl!O>Y$c;AUG}Fj;kT_ax*_QEE?VC7J8W'"PI Ăz_ZfF@p.KTx+BONnsi^+۬~!RZ|/[??UP $]Py3waݼFw|}NcXNnOl%Nnsy34sV ^O=xwQW;J`l?o(g(_@sZBAvr/ !T s|59;yuiGMkN%lcekVf5*Q,WJ?W& XUMj !䃮*'I2; 3h\F5\2qxg,'a7ѩ-juweav'7“)P.P3yFJS@A))7SŰTA |g7Lc)u9"g)n~uS7}C)$lM`Ưfڕ :7*Br#%| 8uvu7HmB -pVh ڂT'_;;Sfž<^҉0g}ޅk|9 JY-=mTe->TNy G!n'пI! +@*^*oM@F H'٫ĺ[AXgBs){rvl`K|r*=+惔&~nr5BԯӞTz;n@)=ie N;?lC-3нBea±իL},?tbi9~Ok$606 IDATFLcFKCʵ U U(ݴ D}Ŵpxi\pjjR?8ӱ.~|u' M%V T%`'LQ,6IS`ЁqچO]F8^X)k> \*>"pso"wعv'7Im+̊X' /spAGwzuխpsZ.:zmG.B5'nG;,wǹ0{oo)-,~Y515)_|vw&\uBz0 ^S f0\sdi?6?BJW Jއ v-Wuo=Ng19Nz"QIT҆ԼySY{YY#6ů^6 Ýne'w^'#89' 0=5@r=,Vֆ ssۿ _pnBv߻!c N$xpmZgv*gqlʚR^QG9q-wp~zG80 9l{VrBؑ5M@e>Qg#~ ?~54 w~?aa OmYu/8\]ΕMU7 ɿ@;ۡf7߇~[G=6X7@a2)2a?_; 5O9rxX%A1˞QꊽŻ(Two9=; VH3l*{MA9=~>H UwOY?W_OކWd|w;/(]@U@뵯Z!2VW#PohC?[]_Wl(jzxx3@rYqgVCmvᲸU]fjQұ3gм= S7#DOóv^sy3q(:*y[" sItYMUɥ;ol]9[Mb3jjkAG>ee~ Z5q w/_ud8EC ոZ6E`eϋa~AfX-!S_S-% ;pTzٰy2s,'i¬*DWâehI.Y \⍳ICo[ZuC(PMǹ-6P.ضi#᰸=橇|U?ZB=fhVkFD!NacMUN:[ίUC Vt_ZO9He׶C;}yDMv Q~ rwEv*t$P/hI?k1T/_*\ߩh w8@InVH?_:<)gxRx}uM]BXqʈ_SJ " ")~2~CmXI6GQL/k_uJ.fN99Guu 3<>B{N`u2!k$3#7 RΎ5͢Xu=A!=YG~ev_BNTҺpVhM4!6נA_s*@^cZ;A..HoՌSxS[ՏHM;Ofl5lO#4Kfp/<~nK:3pq׺:"v@}$lJ†lO+_*2Ck=}BAmQ}j`N)b!M=0]zl jY$ Lb;ɗj]ܹ]ZG#^Վ/-[!#`pp gsf7:G_{ wDloj T<>:#7 qnE#gT=#xfH ~*9_Fe]o2ݮp3#'U{wC{ S$9!L8'7|juw_T:` n_?+!h,4{WƀJtI;Cɦ[fpH,G ɨEV {u#V5 Kn~nKS6#~T 25+%t7sj'jщ9FG=KGe58GفMjg؞PM߽DkϫPA 01oal*0*C[G,E) ԗTaQW:=NM-=E׋ac(*ݞ8/s2p߮"t_z%G6h+c&# ka@*Gస rKr RsC#S$2 r2|Ac\@kIϜW OSGᰘ녗cHe^0A]VԳ1 Pbz5t-cAJ U:"[TV3zӹgNĿz#oWj_:S n9:H:24*ߣ5T?PxɥT-ePـߦS/f9N\\sIOs>p+\4E,-UPy.EVCj(gDUUVrvC_!YVgjV$c\ypvh8ӿ=pP(?[~>R)%( |l6G>#cۚt_rV)*7ZGۤ&%+EÎ*7tP!LA]JþZ F gx%su%Wr FmwZgV<l'd ?[m*mZD!RN}h6mY|L:C&!ɐd:}pK})1*1XvVWֆ\A=R[=[}AħNl(ڰn5|] 7{~9<tT M <~C?@ޒ_ACcMMDa}@cFգRJI*&LJf<ŷK~ O t~덑']IYiwPě?l,JJVMBgVFDê = apkM |[ۊp-~3n~dCC-EXs;>|@2 1$*+z+dvV,pzz[_)S*y݆ٝiS0n1a1p zsg ??2<BgnZZ=~Xf0o\; G04@M ͬXd&K43(,2+ɶ1"kk6b1+b,RcФ?E\u"^s/?8 B_o߄*eNlZZ,g|>b&f͚ܹݴSF@xV2 `1W +):)<:0>}M8YL!_Yrp=jJV3%5* eMI&.,vf"Ht~ZZ;Yg0qBd.,I,,q&|̯pBVcR30C9 9k)o:炸DX!OѺ"NѹܙMk~  P9t{{{3"݈7r/op@%CirL4Seleu^.)\rEkZ|pZG4xBv!y%/rdHN ̜=4y imke޼n G,|dƞ;jpPMw*1xih2o'>𢡄9!=w4xZVv^m~"0ߥC/[[[DR˲2E<{^7mmm(ſ2IpWj1cl8XYuYv&'_gm0 [l:eABu v SbTR\Dm4},!7M{G;~~oǖ;x;LV~c2L@y*"/VFP]uX /0aqq 33ct-73+,E&888tۈE.Bb&Ρ@L'U# "PyZ+6` Ŭu䉵Ntc X]zsÏGk1}Ż\wUݪiG3b)& !ȷ_B/V%P-fDUr?o6O2Y[]&en_q#棵3ijWWTʛ)ݗQɛ)~q~LsH[Sڭ'p^LB1ف~v;ӏ/>`g)d~ ~d>'"e;;xzB-7_0ܰIU{Ѵa\2'^e`Ku"3)$\JLAn4y_YGߠ xlc"x%=(5,Sxs\lHilj$MmOn'? [ȧvOlN"܊Ek޴j\YAš4,*zj$p$+ J Ru2̝IO79舠s4wd *Zc ,>q XryY R R@vSd=Mo5uդr/}UTIštZCɍ*s0*ޟyKh91{pᇜ٤8~nABN_QvMe@φ-&xWH&wMdvGHxG{;78 n"y%F#x E-iX=S h*KX3F c*\AbP1a$oOzRDS[PV?g,jݶg.Pi>RP\fex7?DfJVrRr6mKeWb ԩ/SɈO݌*  +T#*,PI;Fr;/69edUO_&u9MZ x .,1/z'I.b {0V*^F8.|kD7K(+ECСSz8vvCm*RPm~(zP aMmѿavnx+=)7큒9Oz0> O=F n Te$m SmaR)LLI!@ewyE#W[5q%e23#ZϬ>tv-}:[/9d8l*+<?Hi]t ْ av2-Xmr^@F)17F ^~ZdTw6^kxӫߟw<'h¬K0$|kOY'{])冟ՠ? Qs.) 9(zc@a3jYQh J(g+bO Qv\$=(8fWB,FP:'D}WR0C2L-i{`_q$q.ߜwgb0:Eft63Nx%_o$@oc]g`#Īuy۫|B)XYPN)o'VQRd ~f *t7\ ߹=-1SLyka{MTw$/Q@"&ݩsv1њR 6@ ,xU;KC"vgz=$3+Jk<h OYzT8 ѤsBH> (CCXzw/p$17cǑSr ;{9x64aI8A#ƹ=SyR9!mN݄ ozW@TKr,fΒǣa3ÜA73tdd^@[hjnOZ[h 45UGG@* QZ*7t0ҳaiVVf ͐Th. 䈷gͣš*4V)=gNh?d{W}tfo;nċ~Weߠ >v%,Ό(tV7bt,ڰmR5 bY_FcAu2FKUS3)R4]z_ѿSzZ)&[P;_) Z;^jXQr9OU.eXݬީT~񻪦6A--?]FDGwpC d`(KUMqIrc)r+oL5l1S2WV}oiS?(ȩRdXxC\Dl&kO'٧\ ^>HM7?6 m}4vͫ a/mbt]tƹ;:|`Õ=ik[5 pDvεSSy`p/\uaY\1_/R `é tB2'`?kYG7QJBq;pE?; Ug(` Du0 $*G`N#WFApxЙy//<:* ]K7VUDcqG[-$7jYG'AK,.hlWˌ h߻!W^!xa@O6 X*,0h D1>t8=t(a9<\T8c̳7XVHo ^f7*sY4sb5H]g;>Mo8 WROB JUTMpd4#[4;@*D8Vw` z*%m S^6v֯E*$mo+;#Lh?j`1_n> ME:χ9V:I27} ؙTr#(Ws㦧g0y`jH9q,j]R#mp9H \?URH&*'SH Ofi!$Vht+Uqņm7?Oa|FflKXӯv$ Ԍ fUYQPy;+ILQu/^w<#[J 'ERg~eW'w4V(b9oڷR<` Wu# '!6 XߗQMê~\qH R*7UȠHs*\0 J{SyT,(cgq^)X 9"qFqBD5<׼/,;չy7챠J:L"mdO Gy"f\@s}vuDXv'N*=VdN?W}.;= 7}mVFΤ22f5>lTKdXtHڥ(5z6V;\󓲖j{*C@G 1f/rj''yd+yɃ'{H]rN490 ^r0&#c gwg|xـm`cvمݙ9i5esW?JVT~^juuSO<њJmy˓'Y g\9"^u*8jmכ욾ͫlmQ^<"(EVu?do.~d:R.׾Ru~I'Ɵ l+s`UIyDҜ'65gx M%kv`ƴ]WefX\h>:6?ʽ@]ڏta}% EZFdڷž%{6Y ъNr3v>0-Jew#=v-,'MMo/2p#7fqhsXT.#8A Rn{QN_|| Jɼɋ"~Rߘ*?jPѓ#i:aIy6a Nb7W-7ifԙ}#@);'%y黏鎿`ad__~de'yWSa'H66o%zm!08u=ff.op3 3Dُ)E"y=J)d|] "^wEq50c @K wwn%0]ֻrTb/pd 3 9\_ EU3k, CWDrXJ3OS ZAp82 Q1ND@$ֿx9w:σRu$@ Z:u<WD y+J$ [ <~x+8aጻ vߒuunhbKoCxBȅ/i<\Uμ=^{m >N W\E!u \\>#OQPw0!⧓6@\\^B=c8y?f]@I~ǿ!f|j 'u(ΏﾆHKf}\@e&e$H2HܵyNOJ_H>z.# ڳ@=Roo_UF,SŌǺ0=ZK` ,=ǰ$Y\ Q .DWA d=W - Q VЯO2;W8 Ls .X Z}鲟~3]·C~kSk,5￉g3j,}u.GIv,5 5N4DI$׿ .I'~s`kGgHK{[Zm %P3z:f#ѿ8g$o(pE)߇Rmʕ.plQx 9zh⥐$q.,wGNL\|by". [8˲h=y.<󱛊.vm̞Wk ycQhh,F"qӈ@נ+y!y+홰6kGgr6 mӖ@8:tm=\Fi2U߉x;ֿ oͽv/# 0\;g{XԡD`06tpwzo+s9[w>~Ϟ`-[ 'qqGM"5gjv u:Uf͸tXE" 'Hjz_ "yʐuHz$-.m"5[Fu ɾc$;6t>moWrp͒][BV,%o :9 Lw>] xWxuʟW9O~<4t蓔6;1jS?y~21y+sC֣,w7&a&Dd2I2&Ut}s6 Fli:#"do0׸yo6:pd$_<"9qmz?U_(/H l$;ǩ8n2L5c1 z(uS7~iн;iOl|lǖ.>ǘtDPx? >1#\`&DUABU5 k@f|y:S.CU yoƷK2{U->N8It?Go0U\sru;ɚ_bлLKCG8 LJ NۛU.um>WvR bﰩ"7 ߰_Bi]^dB1LO`~x89@[X%w1(gwGV:[(Yťe%7kK/·~ 0d* Q8F4֡рIG_XiIDM$$)쇢6X D! f؏Fn9 'X<3 / )SFzĶXڂ?w ГA3 }DBPa``; EJ[aLXpX:] @_вvi5 ) 0h@:L 1`h:ٳ{UEMI$Tݶ0@ A~0^b 9^ ؏\-z@)D>VTR`t_>^TFW3aڐ%ǟ!NXxLq> 'f C!p \Ѽajh-Yi 10 gpaRAI1A` ]4-t@5MC44MfJuK-H6l\Ǎ1:10g)GکQgr!!?$1E/@߶n\g-g>LBDA*!7ͰHs4| SPaN(*%2ע@M:mȓ#:АčiɆMX1 `3  #M*&!!C$Ej%1BbZL\ރQp&R\ੲ,bوnl1,%&tŐ2 \-'n>AaVX-@co8eVÛƆr(/ W2̅H#?wUI-( $׆qABntvJ7=Hj.jiS:OBADҿk%#EyLG%,03DbU*IhdBFTP}n~e"=MCpTۖH%7?wu&p-dέ VȜ0ϋ¼`FQYHNB_7n*DDeD%`;i%WvCI g 7/`ݑQ,qP8meT*K*[ O4/d,(w`ZqXhXxk5L,:DuY~wW Aq i%uu'}TȈά-ˆ?Խ]ȳ{{r< -H"YHB WǤ0W?>2#1ФC"`Ɯw |0s*!X۸q 0KP-i49='w 'T"|p Ϟcxn }@lDڈ{0YN3 =vIXƸa!]DPAox[ :֏[w\ ͰfZ4/ċjAg'E2EN epegBa;iok.Tu1>HH$BsAeXn-[lAX|A@(Y/11ݮ~X΄r٘*$nlm#7A`f~Ҭ{(&M?Huz@[c;r9_XWfeYtwߠZ^1Jkk+>+[nal޼ Q\ BTodhddeJBojKx/zȮ`/lQ{طayDA?TJ( 1*)sÝ˓dOUP$,Zpitk&[%HGq1|>;wmq$H "2u{O0t'Ű ^JTD΂FlRc׷}rP|  E,`J+@OVpx](p'= mI[RBC344>RJڼ0XdB0W\5]F(]kөhhhС;ٹcǢY1 .Jש:Bgpkc( ݹVAA(Jſz?OF3g! q˴IPTyˀ$kXxST6hg+} [hK |΁.噓HW3O?lS$7l`ǎl۶@ H+^.\ Y|x<{=:t'.“$;e~Vf"΀c$,XEC;Cr7Žԩ-ZwG;˙9΂H ðWil{پ},ׯsEN9KoorwiH$<ӟr~!ݻ0B @DK둧IW^Aa*Tys`6, ^7O=Կj޼}I&LN0Znޣ9 >l!w}6M+WrUEa۷ 6,}iW6q.^D$2SʶAEnEQey ݺ4i*hx_SD'xrkR^(uuF H8DtuvO,0 y7/uKG􌉋Myql` }+.e ܱo''[Xf,g H#ڎYXSӸq%; (4Igw0ʼ)rCobH.Swߤ$ _V#zv Ug 5 aLE=#:tC#}XZ:inNgOgyG3 _ :ؼSR}`Gf}B$|{\9@-ZҠ*.( L6Y@o ,Ϳz#k:7'jV E),a48rs_iI wqP/ZN"eVqhNնN.]kj{ǵi\|;Ҟ$gvnZ͍U-uSmS^OaAjQI?q737[8牥Y_YAnK3.10\!0j~L.=3;JXYL~ `P>N@rK>0ԅ&N]j"Ԓ{p v)xGhnnfpp河ܺ{+;7CWdQCȁ>OAQ$?'6[-YopPB+^lȔI}B>nHvAQf\S>'kp\>?O]] `:x>ܽʒbb$vlb, HD2"jFsMmkAVC$:KmM ?t^\2t ! BIp˃|yq,`]PY*Eh$ hJ&S@ptM#X~ Mo>w!fI#%9M36'ŕΌ(}Td5>pf*v@ !qz`˸[c]X!b"Hzb?EXmdirυi`&XS>saݹ&E3{tP=i52&tgẇd [^걳hIْ,jh`fsR% -:2y"_ 4-ށ!z8v.[T`Z6cmmuVYxaQ+u'&[P.F& w;4M A8 ap$[a~*4ϥr #GFs4iqY~/;6疝[( e$)RX>5R:YѯogsEZNCѳel\SǦ5,oKDa UKvLP@Qjt8J,]3-=nN,nj<~SDM#Udv,ˢ_KG>yO_dFm>ܮɩRKn)-TC02AS['Mm<}:vmZO2=2Y!KnEOh>Ma/pd ùZ+@-ArTZ:'7 @Y<.s/K_/5 +\j{og[pfAQVHu)[P_EI ֆzy.d }꥓, IDAT4.ǃF$DIBE.3bP,s$~)߲K:k׌ lQ!*"k;"#]񷓎7 n g MT$ =ݵ`sI|` +3 ݗ} 2^Zhwi$= 0L ėش ,*BgVe`Ô#48]wGIƧ{ttk']\yS9w}~0fn6ؕ=+--^qG )a-0gp@ݝ,9^dŃ񥬂F&tMR3i]`Sڤ*GO[<\)Gg{o}:Ą<aiF,UX o  tcK9\.PQx _˯_=p>YN7SKQYmDh;sk]4wq}B,i]jKApNrL=H1TQN~~ٳF4g@b- $p 7`/Ѓp0c_\'nkf' Yq#5x<Ȳ(|% SE3"D;@jSS:۷x2-~/p3@R9,sZu7 -Iϗv\}\iꐊ{&_ 2{XFަYŽ76eƵ" (t*-,;eCm|.Qp1J=ПCyd,mGpnn~1c-c.'BD dO<U$ ]>I$x>1oy\yE2GӐy+s{Ar!Je2 !^'geJלd,m˃ "`#C..":,8{+ڸ ʨ]˲P )&Pl_.[$}Dy 'NE,2&KnBkFm?zʂ.7JQ9gzʎXjK'IFgp1쨀\r ƭq'%982f/Njio@5$$#Q!$Lv8{Gw$Wy}<9mjBj%@ M26`6//c^1gcDϘd! ,⮲Vqr]|NSgf< 'yUlEQ>CG/z CL6ю&[t]9ߡlٲ*ˠB;M䏆.ݹ ]un_7E7p>XR2:{6sfO_Zε] ` =ѡܹꐮvO2w+JiFj Yڢ_P=÷U<0Y^SӺբ8W0c#!91[/DFTܪxjXIC@>~fɸ57`!&s5ڼg0o}Sw^FsݐW!@EPC +1Wg6Mq2)sٳ,Iwm[U\ҵFamK4!Q6oO$P ֧=.tn$ܵiz_$ѧWWfz.] r(k\|V®F9{p!9ŨFxYFUC`S `kۻ_ɑۙL&>j]$O4m*3y#s Pɺt~a?ҿV2i'' 4/]l2G@9" Ja0:D95Dr6蹈QJkw~+Ɠ'I Z4bM@\"1e053Z{[nB(hFX j(HN`u83J! < (쎉iZ? TA zju8Pm|kh|p)9=/8ho\U&gF$!1.WQ vYo}yNNnS!"k6`FK$Q%((j:浨(D%tÐ_:']ذذN  TM2rY #OL&7&Z8iB4wZBG/P=/ă`d(ESz/ j<7l c`%TaC y>>\IP D뿍>3a5[Zףb\wl0>FG'GRZ!:&eϠ} b:Hb,f&|[h&hf&$XQ7)("C Fj)Q.e0%i[8'VB(*j8iD {ňcUIh=ÿD$Bx.0 .]\0 п6kI޽P0h 09_2皡H={c5[׃_P5Bϩp~ո%0RβG,j5@213It3(4udzғv^K+]NagFDw~!Pp 5CCB xik^{,+,\v\e HxN9`vjМR`x[ЧeqjR oҥkÄ[U1zӡ`fXzV!W3e R"w\+ksH %MFɑU]u -BB0"F EPAʙ[Z7$51TvI o-/^*j x2/hdzy&B,pa+Z-ҀNxw!hl#Ծ.$T=>fgjwa{L˚޲Ě %H/B"i&LP7hh3 z`oEe)͝E6 rP5ځ?ZXѳ%|V,+4Jo 9c$ĽWHb0BڱriL=sX>{5lٙv;Uj(\^j, L镐Pd:c2+5Pc+;0xI: g-'CPw)p.|B_ƒJ *3W% ݟ@ E5c @kj/PYB-Ӷi'>C)/"m=BtE@x2 uX+bKOUCsnwEE)=U-1TԀ]7y 21J]혩ҭk]L+dHdr%4|CC9{xIA- қ@O<7Gep%l mNjgSpc]:.Ϡ"{Jzr3^?TGvjfZԴ 6 =O<'@br5R?t uΡ'ƗTH\-4顥gk/LLCdrH*k2G![ʕiBql 4~CZfMIkh`W`F4z'LYI\KB /S[jyQ̦rk}jP ݻ*2[Di͂@ Ir9>1|0<ŕM[Pʹf&鉺+,#}'4顩{sI.g@К/PĴts5<]GO!ļBvI.WըkF 8AOxgxA-묌]W?Ny9YN=J)AX3kvk=KZTI 0﨔?HLW̦IK"tlqe.Q-WUOYإ5 oЧ>fyg>2R_Nlix{B$شoPcc*}m>n Ajsp5O,6%xp܄zWXU?x8oܩz2`QXJϢ*u#m'l[|=\aD#k<00_S gxUSbͨ)}jD逮{<\n@Sп L~PeSd_Z\  n.[X }2tr2JGi\ѳ* Mr~.WpoC{2`zg\soKbpn"6M Փ'syrjge丧^?)I+Q\Hu/@AXtHBy21 D)xL¿1 $b;K@X^dg.z~B6`e) Zrt+IA .Sa,?#*O%):r{)5\s+E6>A|1riFO>G./E4oP hb~ d\˗ZUyš@Sq:w n)G%-T\KcLiՏwʒ?#&96@jl0$RFx@/ESfG xvLS~{;v{”'ܿKK'/^?eٚ[Fu'sMųf'(0B-YؼIMf`:z$0ćΒSJ ;mn9 /}IQEwp5Y@9Ԗp, \).H,I p4w[2z H(u`dIH3l2Ԧ1` Ɲ\<7֞$$Z+kkgRV2$wkɃS(pAX_K[η$+H?9RϦ=ęËbQ ZCv{">&i<2W"ڱF=`{|e9O ';`Ʈm| r*޲0-oD FC5*}zrnL·e#zHpE#E)ɎUPj,k%p S5@C85⎕YY厼"81dA ҂orpsvDrH/MczKh@rtY0Ep/-%\eE$i25}ei8`:H oKꀽ^Fs?*6NOURObTCW\GO9؝~-{d~I 7ULLs S iWCcޮG-NtPa]ng3Óu{i-̙QO12Iϧ03Idu Hˬ_ęfC5K_]NIi.$b4P%A(( P(O++gYsUeba|t<%B@;4rX9?9}r"U\rSg2fGMln\\|5ZE wek~|/@t z/0wPv;&msZ:w?W.\}:qvcإpyq!fRC^kfk@6]S6e_}2\T+(G]Mixy^}$右0/yY3j2ז g#}{NWjQ0Se_ ̃He^ o `(Ȫ/( -de5k8 ȿzY %IVd'rE((e<Ƈ8럓|l:aHwֹfr۔^~YxŨHSgS~/_zhFɭEM&q~ǫ ޺?]h?X~pUM# Ԡ*آ?'{qѳw;!+)?3'PbL̤dKP g30m7{y-f6x(#C8OWN1`%_ ݳ Kb!0|q5Қө65u^NhXj c\*^}g#]\FΛwԀS?ezPka%MHO[0Co| :N/*Ze丹ugʶ2ryOU8[Q3x`P$2q`y\S]$$Jsqdpe­_/W<$5PaN;+SHݯ,z3G=2:6|Srrֹc'Cz*C],|T^鮄4PixWÝq;Võy-F++Mpx<@I2]R:ߵ'N:it^6y;K4I&y0?٣2A-1hZO"aoo15sf:NoaA-`zwn͑wV6E9ʁ4 Li-I89T" wX̝aw ?P)H 0y8T umg ]‘ɹN#, j?'o/v`FW>p #E_VHn9i;Gc%zwםa[-qaXJgñ o)K$1t`Vdh \\ƽ;MxRvdӞ+C'~%NKu{o IԚH :^V9&P Fʿ@- ɒ&'yϵ\`&kgƢM>4'Sb~A*C1| W%sqkT:6VzEcICnv(.u[_ E/Ϙi7Axuv9 /L/ L0?aSR^ rbv=m"Ž.:B,yrHqѱ2Z7@8LS&&;G= :2UzEsN)[]d/on*<}+m/Q(uR?I떋Omn|dIX %4\BKS} (nSZ#t ǺFP帞N0|I<jj#0̦IOz2X^0{WJƚM(Wew5f/F1,xUd_&ܹ *H}]QzeV eɚ,{; "y#-_'۝uź͛Ԍlc3 eum)KD,MEQܗ7ʼSxvWBp>hs2N8>,WYgR%Ï%Nrio0xh?fnvUh(rך ω?Yrh6CK>:V;/uTzEsk]{r"Ek8(!Xqr4=>\N41Ǟ,b\dBC/>̦K2n6>ԜzAq8uЃ<&9Bgߗ [67\K6*6̱yźM߁z]qx]}A!l*<`n&%Snif:BdN?Lѱ41 cay{CY7t @Z!=G(ZQ+GE`fKz~RΈs}7ѷ˾ݧECD!QN|O|T`BϸkOݜHp\3 vUQClsLDq>5iBHJhFRb i؋| b˫躎Oc455LKK A ֜7rnSC$FfCMAy[߉7ӿl 7cTx{|Z eI<!Qu^Nt-l3?s54) %ej*gX Iz$@楡R%12Y2ݻ|uQFGGiina+8nibRӎ?71M櫝 D4;iO: O(@_PY8$$; [fo1h_"#ZY W&At#9IbY&#,#`-,㹔ʥćΜY t7q>G!5}_F1MUV vƠG71BzX_u;{ qca鰦î01h+o;D2u0mۊwiHҲ03I65u~S!"JYUUbM4Cn@lbq8sx]:7|J8}1G-H ]-wR;_\8fPx>=)n| ߭rϫ'ħۛj⃉g2fmh#A v3zSϑM%HLJLN&IR3)b D pP(L8#m Dc"MM_U[i%ɾY)E~ !_+8 y8|[U-ܠً4C_۵vc|Lyxch#i;V&xpAWwM>µB"B Т:\:E.$KMg0r k%vG;ӜWTMC!HP2@ #<@aF[6tĦ~hnRx !f?"jqHFdnaNj*=G-SpH_xå-[,U]p:LVO0)RgTE!h`tu.ԥD 0=2\lzbw:5Ƴ޽k_U>3__S\@{Ogሻvg=“w u nlVY8 ,`̡uJcMQbtO "+n;hb0Q]bPT͸gjaW啠1tg J_z#?Q\e!91?&VqPB0y搫 5WEO'%gfӱGsH_L cӆAS`!#ُb?T:n}JRvQi/t ̪s?Aw@jލNu#a>/1[!Rm[G*bk< D8 zַ 2q\Qu}g[^$pOQh9Yf aHxiM!/@6>6 ':5چb!^$ |VFf#]K^A%XV3ʿz9%bNa{ gǶg\Q?ZlFE,^\Do;_14dz چH v%@bMUj"{^]8rrHV*0ZMoR/ LgI-Κ!{ =puʡE]e`p_(󻐦[Q hdeIۥFƔURvUeBp*=3aUWD4f7ǀΔ+;(U 3@ny"ͮ.-]QG-V&朦BeH8Fϗ,)iuN <)EТ S~[+;udƲq39~q=pK*=(\!Nx>JRx[r:@W|ϻ\Os~8ud q-ƉoCjbSoTgP0%{v^kE7O"]W)a6wЁi;AOgILcw㽌ewD iշS^#(<:rβ/YN6orWs?ʖ=poVzsw#u*҆f|2_Xfl|E~id'G;F* C=~zHN$3,ȰBnn @v;hhjx3xKXa%bAO\KΩ*XSBO/{Hr:-ݪx窦/'mϴ|Pq 壀6&gg!qv.}|>־N>CrdL s}~OX)%88/Z(@Swuc7iXӺhcEMjHC)9 Ȇ`)Ѣ ȕ;)T}u`狫FD#~y(Mv+-{|_/9D]_}''Ը&n=/*+FVgd?c'95@$DnZ7uS7miٰ-B3Հh{M,4L9{Dv=,̿6mQT={ޔ[&J#.I V?Փ"Cҹ `ry#^lva8O˦k^1z:/>Lv2I?y9(4mmS7_7u0B=>bF,{?w梯of0MsujWlҳ(In?y.@Ftz5Oٺ^p+pݐ8?*z*#6w,K!-a9lPCͶ1жq--h^-lKP5hFr;Ng`Ow1;+.P4WUA2@ rJ+acޣa@O`;ѡUA{L/zMG-j\?Mx  -4g -=]4oXC5h'_@C…znG>=T|58:~" QxW櫟S97eC `I(|۫} ^?9OXp8*\p0X\JGz5-FZ}$I ġy/EZukovBfB&RLgڶbjOQa@S_&/W g'(Z6L`KꡀKQYFKФ̻P/ix"k5JhꀹZp8O`W!Ֆ βXeһWlyֶ-Y]h*.ڲL Ӳ0LK&饬}MŢ6`.P'de,Յ'5e >Ŵl^P34uҳ(Rt+R?C(qg(*\ϟ{{1 }v9>}$\`ACm IDATaH2$i,N0HX/[7T\1k^˟gM,p5|UI>&%W>~d':WcS?T#ncu^*^SŒ&<HZZ^ W} nRrʄh\ZN( ;BpH5>z XӒ/+|gnRhqI9-o*o, )84uEvP)3^deݯ`>.dz[`E8郋_{%lY.Zf ؄o&@SU6i~O5t'$=$ Z`ÆحyT!_,ܽg$-D *i"!'M[!&4oZ,])fy^DN A+|;;1Gm50vH"Ȭ1PJ&D Yk0@3V%:7Yq)*\JCL ^^ђk*KdMhWy݈>!k_]ɯg`uo~~4)5_(}vi3dM>[]Y8"a¿^6`O,Qf VرVypk/ٴL7q_|iA^ZeNv}C{ (jdkyOHq}͆k]1)mSu*k?o1?+A?%W<a)$zػv8xA_uF y.Q( jϯg[{8~mB]mNQ%<yB]_q % 'u8:ÙhP9'Obs)2QzlwǼR,MFe ୟs~[w}3;~$kx;/ZwwC7q_][*=WEE =l_8piPj."c)4񬣶u@`,mнOVzJ1$|c$F_8b(ppѹڨy;ww_χV[8Nu64 -0S0duńMzOOԞTcg k_گTnQC|pCK=\p)2{]]ykI.)Z?e %JZSRM p+=鄭.9 A/C|ך6@!%\ ylu|G=dlb[{XڗrŮj #1Av|`KWOx9WkF=-pH#G˦n`dԱ]+9̚W^U}PT袧\P} J !ԴZ^)vɜ*2m#)N=T09M~SBM|e^_,vpG^(#> *oqgpU4.EK^}r)yH qe ZvLeH!hܵ߾w@kpB`$'\9 c'7 -l2RG-edz'u !aRΈAւ4mci&ۿaN6~h뛏A4h=(9~_cF$7IOwנEf*Źװ}?E^;j@P W9U7v@8O}syewGzVmv:_B6F/<-YL'5ȦI .>H l'B n>37dL[k`&t0n?[pTm g`ş2cWl?m7_t)E_yR F']hĖs UZޟWYc _A|݈' (!lYOez."֖Fv|#v61;I E~doJ]!hPNw,ؔ5s/odGR.Nd/J#N.C6?Du zaM!-[Uz&h.cK6!}v`G Mm4] 1]Y'pw~ֽ} 5XՀ2m JЄm(bW!KNXr6'|-{7+`K;.{?N )y//R=˟ q"~u3nף˄= y^QбFPe90˿a5RĪ;%?R? ~3aNys)1>Ԓ8˔e$9I xuV@/~1&_e0Uzy=aj!_++xҽR\Rftq蓐:\-Ɔ}r !-]϶f[#%[K2r jF>J౹7w^Y^vRlY,uʃS8EX㲥0&=f@%@Φ@t'cֱQT+^ŶfEpݶJOd_݄D>P( cPC)ֈ]R4}MŦ0}vHeܒevm{["+:w)B[=ꌥ k?sX_ ?|TRcm>_2L#X `me9ÿ1duBM$RrgI &&8HsjEp 譺a?o u۰ַ9M7㽶o 8H=\-^g엗AvUG'=W[^/cuo.58GOLx)&?(.&D&g~䩟ݷA-!Z5ԁlB 4Q'Hk i(W wjՆ<&K2ŋ\T`Es'ϔbm5V6OrBQyM#h?FYt30yipW'zx]$#9 *ٵD 6A wנF:Bh5hvp/tRC1w;;02E焢x崼Įz-BkM{`|F/!k-5Ua쬵~KI-_[ oŰkU%NI]ޥ)-H G*齰O@)ezSǞ!;ulVs -؊j#Y B utً}d Zx e$ICv` +BKhz4ϥ{xAq-o_k[< 4z=t #vɱNxl?T5k iH=AbC&3q`QEb4~) |^WDŒlſPZ+QKǸR Vxjm Ký߃_pYO44s>X%Ue? +,<7G" \]V$$9 r5ܹƫ^C+M=(Ғw C7GDx<%נ4y}>iz*#pǷ75[^Vڶ]XuAO+}_ 'cXV>X:omWW}FsFzcHs~LΫ]w7]Pn$:+w Qc H~\>8_*ȥ;G~j\ԥ]a9L[lbMfҡvx-t]ΩH3Gf gȌ?Mzic`/Hs Dnx'Jp>g-x$ں_w)nQCꬢO:j?;w!_.7dM |`HbF?|=:^ m""mO,#E.~sǞ!=oT)*—E%oCD[*4`؀赓Jė+>RLnE'[ J -8 *aF.xau2H\Pyg=,c"Mwy|VNdl"v>Jӻ.43gГgɥΐK"7ul8zoQ^Pۻ8;j]Ug깓tdJwDdaE{O|uB'*8\C @"(@}tj?s Hg|NOrzU^{bwhhMxzPݎa^|~l)"K+Ip"ZYu%+ek@zjpgdrq k`f.O> 4i0x '9SȔh˩ӌM6$N3*ڂrQgEA)ϖ:rxn!+(d(dp3=~ t8 "8DDH+^$"uxr>KK=Q7{`up{qX̑j{`-hPjy+ƒ@ KjL⓫\v 6MOI'kMgqޫ;fm#%SE-$n`|k_wxM}OO/b9`$t>Zw!C8%ZФ:Ur-/j1EC6;P'K{㤫<!^xh?vvtD1IJ;gbGLն//_(kã/?{X` To bQ >=*%< Kw5'ӷ 7S!w!"  M&mpcҨ|+?fCI r+gG;2My-X 4|=2iӥwMRrط \/ LPSgh~4W֘p_D룧\nkĎP#QxXnP^~x/]g@yFw^})79v+|'39. Nh%p\hT*4 mè T$-A须B9DκJwccq"գPC8oA} uA"ς*/y 8HwUͤ&C.bf ɵl۶ /m*Dju;<|ƫAQxt"b*ͤoiwA('`MS_żZk]#`#P0Wnj#_A},| vRUtCC*;^GީO٧PǮ|NnFY |6YGD[(+2xl}ֿ@A]3-| ȒUH zW y&/l̺Jf"jqʖ+Rڄt IVX i/8b'kdǂ@9 !!;ԃTGѦfcGW ;n61k#^N{`Q`i579ٺJD[FVSd;[lwLzJw+ vfK;nN]3vC ^6m`g;nj=:Bؗ{y)jCpP(n]]p+eGġSl-pyP'7΢~L43J'K~th)v25qo7۾-/MP;ė^7j\:5Q$Uj;X)M8 Y9p9A(y_L|5^ȥ( %XN}3yO׵[ 9lm[$ΏCtO]sWJl1~'6o(UIجfiM)>yϱ{Q[)-O O C Qv]pMSMqT$6c93`D?8|-93ZExhӛ& (J ,؅PqsiC0m}V$c> Li%s6=ZS(SEWŠ%(c\6rjƫS15_wQ |'"eNrIDATogwVɻQFߟ75U& (Zl|y9ݡS2)lz^EXNl>Ojt^Mq2qE'@zy퇿? Yn cW)t353!b~EaƿҷUA-PȌep3$XNQ(x3iFC 064{ːW*汿36` ^XQYcײJ3A70 & tmO0kNnwЁ<\/͏ȞNS D",+Bg|l !R9t։;"@.__4IKt/R2 Q|4fF3s-ЕAyMZcAs4Ġ/Q vPNİye||0#C$IrQZ,8*QDWdoBqL| s:wP e=QVj'cAT;ҐFK4 n">WiA\9E9GJY`[(;z;fҌHFOfltJ6 i1TQIBf}.uXl`8sJa${S"on*+ ax;;Hz%~i˻"/kE΢)UduTDs.p3tp6V岑ˁ\O>VQ9()cu`$%ZЅZŦѣc~_I.NRu"|(.f~xCgߊĘ"kE~>oAtAiHp`h?}ScLRB;W)7 _7*RG; c T\;w#n?/ aRPJX5a5ĸ?%RIMcNQ 5a)?vӐy7R4ږ&rNwf/ :#MX68>֌ys6S׿ 3~k^o/D]Z5$AX-#7Mm~e+-0=YD`T">_FbJyw s! f*9eV@SXM̄١Ƥ0S܎*6(ΡNzƆ7#>vc>Pl8B%P[&R< Ʉk9G\?ݮ; cU]G"0j|]9? }q7pjM֐ʿ2r. 77@ˊ Xrf9)_FŞmW"MgQ-UhwObsGMZZ7L#Qup ^+v5z nu)<[ɅI?ǚkaϳ9XTx"-Jh\w g|+Ypr F?z]MnXtkžecϲQL Z/AZ.UG~Hwҡ]KK<.'bqЦ6SJ8jP*#^oyȈjQRR1,TBX3,؍r1z!XճbW[o E,Qix N9в(aVx[9XTWapN=Aް {xI?-Uo@5j߭& ^7i9H;ss^s.6dL!Y_4h<$uPw_p߰doNomW:޽ƤuIπC+8k+ Ep$`Q_9AUGHt*~(8;Peo0^gGxj@ҭ6\nDqPm8NoTIH_n¡"B/!j(EN#poRۡ=U#eu2]t蔳t-J#ϢAf=dWbB Ht.*2EE!OrIeDJw ԙVr\wgv7pG r6mCMhf7=gӊ8sQQ,S]jw\WI)YcT0]r5Z-#Ow(;9pV3bUo PD Yɢ cA^}QVT/c!V*g83j5{ kB%^݁ejR +(s gOL i%!Y>_ |cՈ`3]p[-Wġ1QZIF U^?F,b@+:809osJ{L*gZ,&hݡa 8?2WQEl(E'"0_w8S57G jgA{yײM?3i2e[lFaQM[ MBPY2W{: H أCuӡ#10ݚQw|Gipᔒ`AOba(eki-Q &0J_#p6gcu0? c#xl?A;SX|d#8MQK*fEd`A ©+ocߛܩr.{p6G1Iuʁ(>p9Р;0%,?/ OfG`c1-vK+~u~1R`f #<뤕,Gq%ppt_`s~B0Lwai _&t*'tcXYN\Q~2bC -4[/7aHﱐY1\=B҃dF<*$]ϛ~wڙ=OH NHNyX0jXw@&xSP,.P9Jmadx2788̔A) Y IDATx^ \Wu&Z{Weɲ- Ę̀!0@d2I&ɞ?,?d$ac[Wɶ$kZݵW|wz]j뮖%H_իݳsu#?=E^8X/MrvP>s@"&9 9lrHKJbA3%ɵcrt9 q\u<~Du%?2t|L#QR|PlZ{r\GO*'3ۄGxXμ DЏR @)v|{=}|oGeΓ,U-ۼ-pl"%Wr|^ߗOXDEVMC{mtJM0rf "*BV%%oxI?'r|@9[R2쇞^76\)5Fa7:DuJ+aB`N?-%óx-]lͼv%&5v9^+R1[u޵Umϵj0)N/#X.w_\# F^[- b3RJ9& y>& [j}.UʧتՕե@ y%H,ɱCRV$AR$}AgcѴ&$-JZ4+ Ќ9yj}kad'ps?TK]]Af%-ȅȮ&0녩$m]! $bp afaSuz{Id~tIyТcL@sR&$mjf./R>:_TM]D+VZ5.%e }!J|oGK1ycqprE7U">Sb]:xT$Ksnq2o8jh{Ow:-Mc^ PlϭA[j^)jJ3mJgcSI}jk  $}9뢤JUqq^:~[-pM0 J I@!)'ڒqqȾEWR(Yh ξ2w]TtRz@|T!9mJog8UZa͟zx{/TUD!KаI$# ZЖ#ٌhp1UMH;/x6ݯF/ iJQ"JLq/~IQ+y%KȨC<*@yX҈5+٘ P;x;:^wt}SV=mΗz#06fQ:CȾXl&B#Fl$'lLp9:g-I7:JqA!4OHl0vtWMZJJjXPݢrP\T (M8$ m[⋽.T$!! mFzGpS6 dۢD^W]GOP1#%a.¥n}_iry]<<}4'Ej V+5hch#'9Yp6(Ô KQizs%'N -@Ya7*6GwG( s䛢z*yxc|o,W_ta̓5"1Ve[H5':h$9[^!ԞGa J&)<-޿Mγ>W^t>'\R?nb2R.[U^pE7{l$t?&ee&YQh|WVkCw9fDDHTQ0/ձLQ|^a>=)dAB‘11??%J;Y+ H~IT9+_p;(9aU7$]/c]Dύ(+5l#YFDHYO6v eq2'$CP"3\Yل0#ӟ+AA~sE"& tiݸ A'׆yvV*C()A) *>d90 P$<ώ!79sy5*iSk6 #~wwȘk}_C&:(-%Hύ,y@ (A1!G0pi)R|1­.euvFտNa}o&A2,`4 X6 66巨~,0ڨmҋ/3߸IU$"I\y^i F$m5(øZppM6ESyo綖9_œMrS\V,Q_=00;*@ ށR=h=Zm&D `. :`-bm֪.L*Tڥ|~V_UrQdpBgxFui{4?H%$ni_YJU 8h`?$yc y?9Ni(!`h?p= 0fLVZղERe1U X35,/W҇;دlyⰔDzձjk[G 8~͔sB}cZ Jߤf?4 (.FX|8 iH$BL3RiP(+W+#+aWp;z~ W\ W)+IaT}Zs@;ɾ LWß6R$"V,QigtEѣS@q6ʣc_P|OQ7 FnOrlLwob$JJpg_` IV;G@rUkJu|*iH ,[90{tXR+IT25:Ys~W){ x ;YQD2ZalטEEg:f(?~&F*KXߝ^D9]K i9$ @,J( T zQ{6N:5/L b:)?,̓>;c Y_Z=?zc' ͿbɨUR)G(oIr窺S^ n\W'.1d&۞՞U*=|8|^@*P6gov1>V)1a$@\5Ҳ:Zu07[^5eKrprt"f+qG_$sL>6@7s!:Xp|pQPt'`?X6>qz]QނLOyO% nY;a,'`66d1椚= 7s uƬ# 5z];Jҋm x◺Ⱦ;,>2rٌ# V%D ҿS!F') 楸‡{uTn]VX!ҴR͋!e˪ xb)POt86X\D=0U^[ڡo;7JJ^u@Z$_WUdĈ<ƀD=y/@>~E vWIкW%ŔS"M& 8P,¹%J9R.?1 i(~D5ĺwί xΕ6i[F䋿7k.3H;!e@GϿ:c%# ovXaHU?|Lz@q?AQ;ЩzSCiAz@5+|lPTTg |Gxϵ̋XN$?*huR7U}ziewQ-Yie7Z<%@?L5M VQ85f=ҼuY#ֈ,88'Fjs}g٪&5Ƀeb'W] rT@(8iNji`g_ G1Vi URypWp`iB#]dod$$^g$1%Lѐ1ga׍MP-\!$%ay|pwu""5^/_>ZeiANdhG,p;-{uulʉNQ\k*86S)ϖ+.C6Ujud^FQEeq'npF!Fw`Pզ[j=jK9mdzH>;#HwE uj@2 !$755iW`-ưd"\Ohٯ.g3 C &·ޔ23fy,*`k%Y `lsr#h>Uo޳D)a7 o>|.I ,@ RHwU5!Oj0=hJ}"Wҕk{CGIή_'؀ܮw[~&|z9WJ| 3axJCY#fZVVC7[j.Y䞽w,dB?Џu ?_[^X@ IDAT`.bd2 snR|- )#=J/^Րh$Rk"NG'D oCx +yw{"zj`P"Ib`asx:567sn.4i^f. 6HT{ZUŒ:مKRdͲ0 A{gƸѡ'G3rbMY$>ٞRZI" [*mM^eyk贋l }(_)$*7YDNfT.g:D\}%3珛+kI(m̂mzυ^]Vo#<9VY1t~ؼS/|s4&U2jqeBr|/rF{נqNǫQ՚yΥQTCl|3Hͼ1dO!;'GK :* r#Lbd<^)b쵹F]һ՛,ӻDG'{e`@y=QjGInAEUu+Yy'<?¯5dfMΚ}gzMo*5[2$E̢U )\4o% IHM 6S g`fF̆R#/rh274phƥ ά[M%{-ؙsl{]1xA7UCI[ Pu7M/?C߽i?$ 5G7yzhY%~қp3R|?@\VeyLv% (8F XfK#{1{SHy3߃oв'R1ӫ%vw&t GSk' f#8?#5?'0@Ҭݪa:UϮf|iS>/@9BL[s!ܒ+99[>wް2Ku`ŇNmekfD[ @_+X|)[qM?ݏT%J)Smr~?LbA6m[8οSz۷aӞбaB  AI׉"e }bgq8$*HWkZ|j'AzJU,%G( Z%|Vbj-;ng#-0bζ{esͶSL >5CFBǹpp-QdڔhWnFyI!y:oû::O<1,M}}}5bvSU!)y9tpi{{2=p;EMͭeW?%\N3`rv'Z/Ql5'MVv:xjnI0Rn[R ?ro#q6eTM )k jC-Q+"@fzP'An3뽒̮o.4HDf #L|Ĝ#afHy dGee)4t'lF_7&,᷐=cP5CH{DҲ'^BSq;0?&n9vhD=Ҁb"]67H*LNm춋(rajۡX6#3GF$m˪dޗ˖>D̼~iNU~y98SiVQaOq/v>)5u3_]}.}v7/ÒTw8z_ι sO.TI# Q!ROg ՒcyB΃%df9&W@hۇReިy&ES!iI{`gH I CFNm줈˗u&,vzZO Tց6\(pp m2["Dj2K˥H^{3MH(S#k!˜V2Yp\v a%9WaMzA &z:̔aoT7*]s#w50D%^7$>"h bśy \We'|ӏ& m[fc0,vtCnCVojtpoACנGIQLR0N"Fm3e4_ɃYKzu; , =^q%cf3Jz)nWCf0"9rf_ޛ֚l]kN[UK5X#\ڠr%z&ɓ_LMBԾt%b1Bg~9"/ `ֱo6ݱT/Wi^okPqE5"/XD[LMhwX5vԑp~RK>%^=],A^lti[t%gvLI>U-J E~{Fw9t5;縕nZF p)n݈7}@kH!EoEP+W6n*]]UB&۾^Rv#pfE?3{_o+K psJ~$j O=UɠyR=z%h QzX ʿacz6$ HAϭ'Ү p?znW2ֽ>4m3?=<56QXNJX%j,f<<$ FD)a'Q r{[Ԗ795>rCޠ,Ϝޯ SC}wx=s9ߏցM*0qUnΈ9[qmC |˿DKѮ"MM@J+]IM`UiUʙՉՠRړ2JIPF7|Lٴ{iO~vѽ&bxcnV亶Fh3W+.WJ9)y)lY{K%aQzx,T*c(kF_Ln=IJd9joZ'oP@lV %| 9f0w3snRjB+R 7"s5"]{w3Bm[yLQj[,ɭ4Y n\,ʹ lKiY+zTtCx҃ :Dm=)Rjbrעك_RiCQ H^)o3R\Tx>B447DMjd2t*w"{o싚.C`_,CS@聰fJ'.=xd~Iu" DhS"z{#={gxHM>!È]^FFT9g8Kw48NqOc;ܱQz|8/eiZƄ=<'>z Ly4vɧc}E$EzO+. WX]ǁ/%fۈUU4N;߅WK=lމ[>7XHanlI"X&8X=Yd 2 wC΀L15`AT6G]_aSu g:a\ߴ\RY@ !1(#!9W$ )ӂ휥{i%h9=~*8MW}@l_DSdžg}$YEsL5h2 qG FDqdrVѿJpXb܃pd]Ada-PaGUb¼Na\r.iI$%i׷z>)";8Rxs2gx?{RS@]Z-1~،0dK&\vņ+ߧ~sA6r]}k!Ž ;$N !<ҸCz]W3Qeu3KoB'T8LL4;,>o¹k2 IBT̼$/+!%db įHDZx}OI 7S1R޼ݮȾ":f=sO}<xݟ iϔT;'x7@m7# X؉J`/@=a= &'~xszJH5CY̓ G(մ9C^gG"v_?=1Oޤ@;naIzّȉ^vľEb~׾7v%A$NT̚xWϐcmP TP1Ĥ{GXd׽ulL/bL*&"~lqW#(|(R}I$1_&r:xb{bᬀaN߃#")j&3sF2!$^c;<$o ْf -z%Ͻ̒c8&w{ma%m )r;w^Ƽ؈o%bF[^|$$Hs :S5^(H!5K$\ uXUkIZrŘBjEHijJRPRkT 9%pU2_s8E?kg4H_Fw9u!4=N>2!>"vbW1+L lZVl^$\bXIDƀyipq`jpN!;~VTTpbz I EH+6i!DVZey=՞0.̝Lǐ|sBn8S{LW3و\;ZXJůWR)gFΛ9?6vں~ M#H8& ƚ^"<=]>TyROf|speQQn߆!@&#QN"tl/,\kM|gW%ʧ$%PSt WWgڸYdEl)"TC 8 ##KGE;!z焓&8!r%<J.iLp'u'߂g88&|:oBIԸ "R嚨G.#AiT, 2h)EE\+Ψx$^: K!DMzs'G !i@2݊xM粹28&ZiUoJ⑒%4OJpvZ_ӆ=M᠔AuTT 6jSL[8.+gіMYɫmÛ]Av@Dm4/e~긆ۊڕϡC/:~ [.L r #] ԸIK* A,nؼԌŽ%"w}H5w*҃LaM$@ڗCSeZ=)0Rc8;:#-ܢѨbTz}PRϝǹsp)8qccXXXPjU~x6=3ӧ;DW\ }}}u9v)u0CأBPpf iu1EkӃu$xIs7',0]vӍvbϕWb-T/b"㜀ѣ8|DbiU»A~Y`9V]k5)T:-WVWܘV1^}MKnLl3&}IL;A_-vUy<ısfNp=GPp_e߈*/yMj( #fW2*by 'FqƧ!NJ|!\{wT-FG$HLA@P6wa׶͸tt",'sȦjTF$*O]"WI&U" P\% aݞ$bV IDAT~txZIF5#ӽcZ2@iܳ1 ^{jҥ@s[ՙ#t5S C8]]z.݊=;#H✨WOƑg1156LLL`fv=5z<^5K7o;aӺ~eP+Pd !H-KC(Fl8duG^d`$Wgzy+!ǕjD4\'& `[Rd$Ußd  kJ@t+Ov&lj$=#'j#m o7\SC#xq;3,Qr?^%Q߰a=DSj@OڵwlAw{**rU4=-؀ > ({&mk^3ԤD|Uh16g0ye"S"M}=[C=J%vMTIS*C._~ %7j<)B8H l:eDcHT4:TʥvbRlϥ|iS^bbm'/"-3 @@-ޞW-D!8oc!mHL'≤I!>C\L`)բƆDA)h;PURYNby/nl [2Q^-Ђӗ ; pbfz sqeinh ͍ ; `cT|X}wDX`emQ^&7L_ Najv )C&[LN +Wng[ Ďԅv kWրܠfx,e̩$֍ގ3WꖝQ 9ioE<*߮JRȝ~eW D h(Y#@}_Ƈz񈹾܏g"JI d(n\~V\m3R QK_ KiQFoznS)g}Rrp+~ΌQtSFU Wz%HӘaxt/9kKxAl8n4Fyp9PBg~VSgn= ROB3k.n\Zh5djsx[1q6*}|?S=W.oD&tta,i4E8}4)4289Z^>.yD+ d3y'SPr痕ҷ܂gQ <^XJJ^~ E=Zլ|i7QCC\ݢY2@f(A$w/ (G>9ˈ Ϩ\+FSk] L@$bnBzW𥗇Ű~}EM7 :9:g YbwL3J65oy7}[ѷq6e& -_?i 0͹ x }ؘj{E藞Tsç!hX.P1U{@-q یwRN|4U1AG J$Nrrhɐ bw؂HvbJDрTW ߅~0Ѓ. H#;/FpnlByؘfyFB -!ԴY$=\% c@hw(ݽ /S-BIS+[D'=09{0AJfDDJIՆ)^K&wB-׻$T$q*_iA!'"f,JW֖>dNz$M\fR7D0[bKM2)BJyZ|&6fMRb??5pq߹R:0yY:Bj$ KMBNCދ1l[~c9M!%]QrC-]"k"#9׆|P+9zޮ <W"EAz[w >o I1ނ1DTB-N2.=?kqGvLN|;HΔ$I֝]Ú"fR`wy1;Q+}氚YSgPbN3r{Y-̼.5[ՍX_^&O!'n S85s/qwNO}[==pSH.ՓZ2g tkgiͫdMHΌ"XDEz8" ޏ@E͞c>l?S8yq7R$D?u&|$-lB8ԋqZPT3m2e, llH{r76cݞ[qz}':{]K,! vJ3vỵ#В7S}v?cwtopQ6#/e [ܦqX| bO ÏI=t+aOİ*RV Y} طY*9dF#=HNYl$alI`$кg'0,b&;qIrn3hH2)PƚtX@zn\g@I C<(ꌄimi}e4n[? 7%8̐dT>eG zw q0Mta#2|6a>[:gHz'ngL*G$8&vqS𮿪TToE ^1AV}vvaygi@B{ /-C/YOv $_~* x]w>\iO 28նJL,Ӱ]ҫ|Z"6BHbNkXNn_+/7d\Y\sbI. Uq{­v1+tR @ ABelbA4H #sNF0(6yO/!±%_nC4tlGM*1߻jĦW|uz(JBIPA9/";yu֕\g( jc!Է#HZtձ|#y2 `n m5Qx 7whpz^;u|pCTRԊ43 3*+HIO}ʩOk!GsI<1/fQ"%KvsL\ W:!+ث*#ai,NJܹWY9%a/t)RiA:@WL(wnRDf'P`hQ:WEV'YJ,Arbc9'2y@CcDuxJ*c2`ud*ZNp!13U::CKyYpbmalunډ>b*ahTr\O)bTMU iP {/3ij`96t2e'VV`3dvqVT&GE_ !)  kt%)ӫT"+E[+@2rh~LRW'/MD,, $e(b'ZH5+=+R5ЪUJ}I-GIW^"JM)oA#=hT^Kcݮi]"ԼRd9W*v&;DK zJ<ɦvK tC^y#{6 R̯zwsVe>Q>Kv*rזk5D,+:'(ZBFOӾyy7*L,>+1Lu\+xlX@Rpl^AC 9(XN:^Cy"qa[[Ésu1ʍOme1؛zFD:fRLNTj"8[@gOyCZHzlJs].} 9d\Df]#BjRv{1jqcң5'Ǻuk4 +aljC̎!8x,-6ƕ> m؊eM_6Rd.+Ѯ!/ toY9XI{GJ .04R8pUca[WCfML 1Ʈ2"ܨWVVtDQS&OYbXT ] *#mܺbNm#F fObAR >MBjtDZѽrIuDA॔ s RDN O&/S\c{p@ $.U ׂl))KٳG2xjۥ"R+F-tSz3=}ӭͪj$q4&O 4jYVWBߺ;Td"tFr|i-/˖16|VURBR#8 X5Ç$/A9;-t2GNr1&A/"viIjeH*5D\.h⩹n];hN1yL:h6vJYJP=%fUcKW|[5r=I6hx,}Bs>g)@\1b]o^kk G{ȇz߁)sXOG6ev:HYZnG$I0\g0>N\n~D]9CO!'jW_hzBY~HXew "kgQ!X4Q TRVI,a^j){JKRl?/2x̞*ϞR&- 3 UTc!j-`ܻE]1-SL $\%CjlF~.U&RQ ڏ@4>m@WcAj6rujUX1ښyzSzWNNMW\z> 9{zk0qi`܄T +=`zao3R{]%Pf| Qן):V|յtft\3<bSWr9!d"}wCdi$Eh~bqrIΎ,?7)eB4)4j""ϒw;KRZ8~"{(K8;? \#Q1Zg.l22";+.aՂW*%5'>柔VruKp Q Rv_QfD S~ْG]мh=` ĵܡfZBͻ3i,'gS|i ;36H-/R~ +Wk٫>Xcԧco*dfIԞVzFIZ|*5++@ =W%983cXRRӳ  D1qn'6-QN(#]]#0/N;G94R">=f1|"Z]y_j=ȏ\ͳ씟X "w Ѓ,選H[\Dz솖Y`eUEeDjgKuʊtV%zT}-G4O0rCIpb1.;hZ8f0i3vi &JA:s{E[0%+5T[#@z6U"Wɳ]Ey78˖*uO/;zV+R7bs<'QL\D@ՕY/1x1Uɗ^R*Vi5('WBcI'7jnUʼn!;ަ"A[#Ѐ DϋJՄ3֙G3.D=-:qs#ڡEr\ \***** Nm81{+!?&o@|~)W$H ckߨ#jU #GzV*]l݁,3j A7*uȀ4cCuc9N`Q-#PoW\;F\Ec2v4Hcٿ dp6Ouޥη| cj,no3BMM|AR+;zy΢ݦ*pSInz^olV*"ljtiZFg{-6vNSE862ɨ<8UKK0G,Fz{c(3?vÂh ,Tk8Th5 'AҫF /?洝DM[BŹ&S>!y=4G%\s |7I]IGLU&i,M;'BèdʍE"yٱŠVvRYΩoԉ$ٚ#b{#>U*:+Ǘe,dl;`s ; ꇥ/:#w+Izj9 $/%H a\0iaH5ogs廂ΨUmu vSekMpqaa, Y{!3R@#JՐUAF;eK-}ȁ7LCsf8Ye#1ΰRw i>?Ʒ69R84t¼#.pT|M_F;9<<[/Yhn- Ḯ @BsQ EҖ/z`Z+B䝢c^5 #G1ڽ&'=!OiG4$ՈXxxy :j-2 sz=#z&d15!1v[7%jŒ woc>~V^ӱ<3,9;bi) `|LV)JQ}\iAz.[$ehg`Ksj:I7eΩ ML.%Wb΄>Wz6mF߮FTޔ#v}Kꑰ-29/EE[nݫwBLIK\^qnTr WAi1V 2Ir\70sJۍ۳-;P?[F3#vNzQ%nB"_:>x|>«>œ)$'"D~LàQ5ZfaD&C+ӷ"7rosp3C̽y f#S͟d!* 2Cx6ϛtT4!aɭ*-7Źd )jA<@"m+=Hd8zoH\)J}hm_S<+Ae~ 4s#babJoR ~rur`0 _H8v˛kES5w֋ ;;7H ?٩ge1U6J "X`7B}{00vD9ɭ-[^EL 4`WG`GCjHjS: ovZRqҨ[ @7J w[HfJҩcڊ֥=r$c?:Zgu@qBX[ۨjId^%+|H *-{7W{uΕ7 [}x;%vrB2<'lKn܂ݷ7On5KUvz4fhx 8[#I*6TYwI;X/9m9kQӺϨ:H}rYgG"z-rek%'!ӑ$a-9 t%/!i?%&"CKC"J2jc1bIeH3Fr"a}V*T-χѸ`9OZN #F4v}6׊saGޏh0Du70S`(R/}d]H^DܘilPaUW5c;k#4)S/Ijv'l{05et׊!B)0/Dٗ*ӱ[_3M zIr"/A>r)Et~4OT"Z'z鑩ph╨9nN>{7n a0𤋮@yh>s ^^,hx2*[Czb*kLE:Tob*!X͛`U/F"‹q/NF2V2 I.P$~dq>K|d@SH14ո |G~J~A`W~k(eʚ/}lLi+M㉩ɍ ^ْ{hš E5F*kw0e%jL-u-*i8ЃV5ԢYՋ;VWYw7n&3B|6Baz_;KĆgY)?R#_ʋx]_{P n#5A-?Z 4w3vWQbuRaܟ' nҥLjDC >cK.>W,PȦ)o>%fR7HGgA}aLY, &S& O?Fl4k1ih X.^:@g!9>_XP6Hj*A;p䍟 .G R4Qz#Z>ot0+U[Eir4`(={}B9Џo&njdTKVĝ\,U˴ M٥2 \wL5w L]Ð%F&' &*`g:mz'=Rs *H^b\c'21Tz&"JE64`MGfNfStQ%qgI3n2l -~)HLw"1:]-Q&')Rޡy~{.EsRdvTnG)1;]8z{ $+,#,=+Ihd7{D_'HjFB'Ŝ7ge.Iwy+؉4-jWJ>&oET0B=8n9ڂ3?˔$#oߞ dtSz:ju?_ Vd"dݡN{Ro}NO D%E*xXbm\UM"QiFv@G-s H͝T'j{`wk8Fslq693Bý eRDɍۿ w:1,²ǩ:_8Ĝѹ8?V>*Rl\u6QIxOX;6& 11+GzNH)V{aܴٛV2T"yds0AO2PnݢnڨL0oG`bx}*) Z+=3B}=Z9.*-8tcsfHbMGW Y;)zGVܧmMu::R3<($ #sbp tB)R$7@ݲ# (pphT2+ꓧ~9KqޑT^ٺ朗Kd<7VJ"dT)!Tns+J[RB9c$S'qg"Jure!SRK? MJeR͉*p؁nX# 3aRJG6Ul6>Q3\<2^x<>#i!v-ǯQ"*@( _4݅*XB-GĉQDF  :6:!@CHj z٩PuE%-҉"nv[rHGw=Y|!/2L˖u ++&VOl\A2#Iul^ 1\0m{8TorG$80< SLVΤT_c;q{kt|%v~C+6ͤlVDH.?g\{̺od;|v.pJ  H| ym_?$e\|75|0jF{P?t5#x#& ѐ6{duhb { Dg$V;Z%z$pAaHIRUv/*7}{u-}0&!|,~* , >sH[29PARbe,j'U"dBjK]񪑦hm=KQ)6V®lvLtύńU$ {]{/cnG!n5[UWT)#Rɺ{XߣAU eo@sN*u9 En!<᪲P..mS1XI,W&~6Mzx0\;; `ߺ ^g6;BudSNY.][jz=h ['*8;`y<]ӭ7\YV*쥡v+N]$>(e ΅9|Oo s /D;Nj4ts)]gBIh5COk8$a$PUj(Z`H H""gӸ+o0XfBn##Y~K9Zj8݈^ۓQjE(~૴7̎ S} [۔&J 8g $PHXc4KK4#̭0!)%%d[/j69=I C :umGRjJ W*ʣef;.QM9hX\MΨe-DQ %/la^/,{aE᝻IDAT2_'YFדlDGI'5giR\ %@aH Ĵk5 M7!D;YUTJ) =i}^9Isy>]x}bPBȋbH.)n#Ũ$Wgm1*l k8Wl_QabVOL}Nw̳ܤF/Zi@IR6rT{sF+<.WBL:GMMV%VN7!L(,`zv\vwFuH&JQr|FImqAM'F 'u:ɮ2*-TM*-d 'ƴlB gԍmmMq^sm:6xY ,jK8i\8AB uMCY] z $SE&2 jPCN;*e build\c\janet.c @if errorlevel 1 goto :BUILDFAIL @rem Build the sources %JANET_COMPILE% /Fobuild\janet.obj build\c\janet.c @if errorlevel 1 goto :BUILDFAIL %JANET_COMPILE% /Fobuild\shell.obj src\mainclient\shell.c @if errorlevel 1 goto :BUILDFAIL @rem Build the resources rc /nologo /fobuild\janet_win.res janet_win.rc @if errorlevel 1 goto :BUILDFAIL @rem Link everything to main client %JANET_LINK% /out:janet.exe build\janet.obj build\shell.obj build\janet_win.res @if errorlevel 1 goto :BUILDFAIL @rem Build static library (libjanet.lib) %JANET_LINK_STATIC% /out:build\libjanet.lib build\janet.obj @if errorlevel 1 goto :BUILDFAIL echo === Successfully built janet.exe for Windows === echo === Run 'build_win test' to run tests. == echo === Run 'build_win clean' to delete build artifacts. === exit /b 0 @rem Not using correct command line :BADCMD @echo You must open a "Visual Studio .NET Command Prompt" to run this script exit /b 1 @rem Show help :HELP @echo. @echo Usage: build_windows [subcommand=clean,help,test,dist] @echo. @echo Script to build janet on windows. Must be run from the Visual Studio @echo command prompt. exit /b 0 @rem Clean build artifacts :CLEAN del *.exe *.lib *.exp *.msi *.wixpdb rd /s /q build if exist dist ( rd /s /q dist ) exit /b 0 @rem Run tests :TEST for %%f in (test/suite*.janet) do ( janet.exe test\%%f @if errorlevel 1 goto TESTFAIL ) exit /b 0 @rem Build a dist directory :DIST mkdir dist janet.exe tools\gendoc.janet > dist\doc.html janet.exe tools\removecr.janet dist\doc.html janet.exe tools\removecr.janet build\c\janet.c copy build\c\janet.c dist\janet.c copy src\mainclient\shell.c dist\shell.c copy janet.exe dist\janet.exe copy LICENSE dist\LICENSE copy README.md dist\README.md copy janet.lib dist\janet.lib copy janet.exp dist\janet.exp janet.exe tools\patch-header.janet src\include\janet.h src\conf\janetconf.h build\janet.h copy build\janet.h dist\janet.h copy build\libjanet.lib dist\libjanet.lib @rem Create installer janet.exe -e "(->> janet/version (peg/match ''(* :d+ `.` :d+ `.` :d+)) first print)" > build\version.txt janet.exe -e "(print (os/arch))" > build\arch.txt set /p JANET_VERSION= < build\version.txt set /p BUILDARCH= < build\arch.txt echo "JANET_VERSION is %JANET_VERSION%" if defined APPVEYOR_REPO_TAG_NAME ( set RELEASE_VERSION=%APPVEYOR_REPO_TAG_NAME% ) else ( set RELEASE_VERSION=%JANET_VERSION% ) if defined CI ( set WIXBIN="%WIX%bin\" echo WIXBIN = %WIXBIN% ) else ( set WIXBIN= ) set WIXARCH=%BUILDARCH% if "%WIXARCH%"=="aarch64" ( set WIXARCH=arm64 ) %WIXBIN%candle.exe tools\msi\janet.wxs -arch %WIXARCH% -out build\ %WIXBIN%light.exe "-sice:ICE38" -b tools\msi -ext WixUIExtension build\janet.wixobj -out janet-%RELEASE_VERSION%-windows-%BUILDARCH%-installer.msi exit /b 0 @rem Run the installer. (Installs to the local user with default settings) :INSTALL FOR %%a in (janet-*-windows-*-installer.msi) DO ( @echo Running Installer %%a... %%a /QN ) exit /b 0 @rem build, test, dist, install. Useful for local dev. :ALL call %0 build @if errorlevel 1 exit /b 1 call %0 test @if errorlevel 1 exit /b 1 call %0 dist @if errorlevel 1 exit /b 1 call %0 install @if errorlevel 1 exit /b 1 @echo Done! exit /b 0 :TESTFAIL @echo. @echo ******************************************************* @echo *** Tests FAILED -- Please check the error messages *** @echo ******************************************************* exit /b 1 @rem Build failed :BUILDFAIL @echo. @echo ******************************************************* @echo *** Build FAILED -- Please check the error messages *** @echo ******************************************************* exit /b 1 janet-1.41.2/examples/000077500000000000000000000000001514534607600145315ustar00rootroot00000000000000janet-1.41.2/examples/3sum.janet000066400000000000000000000007241514534607600164460ustar00rootroot00000000000000(defn sum3 "Solve the 3SUM problem in O(n^2) time." [s] (def tab @{}) (def solutions @{}) (def len (length s)) (for k 0 len (put tab (s k) k)) (for i 0 len (for j 0 len (def k (get tab (- 0 (s i) (s j)))) (when (and k (not= k i) (not= k j) (not= i j)) (put solutions {i true j true k true} true)))) (map keys (keys solutions))) (def arr @[2 4 1 3 8 7 -3 -1 12 -5 -8]) (printf "3sum of %P: " arr) (printf "%P\n" (sum3 arr)) janet-1.41.2/examples/abstract-unix-socket.janet000066400000000000000000000003461514534607600216310ustar00rootroot00000000000000# Linux only - uses abstract unix domain sockets (ev/spawn (net/server :unix "@abc123" (fn [conn] (print (:read conn 1024)) (:close conn)))) (ev/sleep 1) (def s (net/connect :unix "@abc123" :stream)) (:write s "hello") (:close s) janet-1.41.2/examples/assembly.janet000066400000000000000000000015101514534607600173700ustar00rootroot00000000000000# Example of dst bytecode assembly # Fibonacci sequence, implemented with naive recursion. (def fibasm (asm '{:arity 1 :bytecode @[(ltim 1 0 0x2) # $1 = $0 < 2 (jmpif 1 :done) # if ($1) goto :done (lds 1) # $1 = self (addim 0 0 -0x1) # $0 = $0 - 1 (push 0) # push($0), push argument for next function call (call 2 1) # $2 = call($1) (addim 0 0 -0x1) # $0 = $0 - 1 (push 0) # push($0) (call 0 1) # $0 = call($1) (add 0 0 2) # $0 = $0 + $2 (integers) :done (ret 0) # return $0 ]})) # Test it (defn testn [n] (print "fibasm(" n ") = " (fibasm n))) (for i 0 10 (testn i)) janet-1.41.2/examples/async-execute.janet000066400000000000000000000007401514534607600203320ustar00rootroot00000000000000(defn dowork [name n] (print name " starting work...") (os/execute [(dyn :executable) "-e" (string "(os/sleep " n ")")] :p) (print name " finished work!")) # Will be done in parallel (print "starting group A") (ev/call dowork "A 2" 2) (ev/call dowork "A 1" 1) (ev/call dowork "A 3" 3) (ev/sleep 4) # Will also be done in parallel (print "starting group B") (ev/call dowork "B 2" 2) (ev/call dowork "B 1" 1) (ev/call dowork "B 3" 3) (ev/sleep 4) (print "all work done") janet-1.41.2/examples/channel.janet000066400000000000000000000004671514534607600171730ustar00rootroot00000000000000(def c (ev/chan 4)) (defn writer [] (for i 0 10 (ev/sleep 0.1) (print "writer giving item " i "...") (ev/give c (string "item " i)))) (defn reader [name] (forever (print "reader " name " got " (ev/take c)))) (ev/call writer) (each letter [:a :b :c :d :e :f :g] (ev/call reader letter)) janet-1.41.2/examples/chatserver.janet000066400000000000000000000020131514534607600177160ustar00rootroot00000000000000(def conmap @{}) (defn broadcast [em msg] (eachk par conmap (if (not= par em) (if-let [tar (get conmap par)] (net/write tar (string/format "[%s]:%s" em msg)))))) (defn handler [connection] (print "connection: " connection) (net/write connection "Whats your name?\n") (def name (string/trim (string (ev/read connection 100)))) (print name " connected") (if (get conmap name) (do (net/write connection "Name already taken!") (:close connection)) (do (put conmap name connection) (net/write connection (string/format "Welcome %s\n" name)) (defer (do (put conmap name nil) (:close connection)) (while (def msg (ev/read connection 100)) (broadcast name (string msg))) (print name " disconnected"))))) (defn main [&] (printf "STARTING SERVER...") (flush) (def my-server (net/listen "127.0.0.1" "8000")) (forever (def connection (net/accept my-server)) (ev/call handler connection))) janet-1.41.2/examples/colors.janet000066400000000000000000000016301514534607600170550ustar00rootroot00000000000000# Ansi terminal colors (def- colormap {:black 30 :bg-black 40 :red 31 :bg-red 41 :green 32 :bg-green 42 :yellow 33 :bg-yellow 43 :blue 34 :bg-blue 44 :magenta 35 :bg-magenta 45 :cyan 36 :bg-cyan 46 :white 37 :bg-white 47 :bright-black 90 :bg-bright-black 100 :bright-red 91 :bg-bright-red 101 :bright-green 92 :bg-bright-green 102 :bright-yellow 93 :bg-bright-yellow 103 :bright-blue 94 :bg-bright-blue 104 :bright-magenta 95 :bg-bright-magenta 105 :bright-cyan 96 :bg-bright-cyan 106 :bright-white 97 :bg-bright-white 107}) (defn color "Take a string made by concatenating xs and colorize it for an ANSI terminal." [c & xs] (def code (get colormap c)) (if (not code) (error (string "color " c " unknown"))) (string "\e[" code "m" ;xs "\e[0m")) # Print all colors (loop [c :keys colormap] (print (color c c))) janet-1.41.2/examples/debug.janet000066400000000000000000000002701514534607600166410ustar00rootroot00000000000000# Load this file and run (myfn) to see the debugger (defn myfn [] (debug) (for i 0 10 (print i))) (debug/fbreak myfn 3) # Enable debugging in repl with # (setdyn :debug true) janet-1.41.2/examples/debugger.janet000066400000000000000000000071031514534607600173410ustar00rootroot00000000000000### ### A useful debugger library for Janet. Should be used ### inside a debug repl. This has been moved into the core. ### (defn .fiber "Get the current fiber being debugged." [] (dyn :fiber)) (defn .stack "Print the current fiber stack" [] (print) (with-dyns [:err-color false] (debug/stacktrace (.fiber) "")) (print)) (defn .frame "Show a stack frame" [&opt n] (def stack (debug/stack (.fiber))) (in stack (or n 0))) (defn .fn "Get the current function" [&opt n] (in (.frame n) :function)) (defn .slots "Get an array of slots in a stack frame" [&opt n] (in (.frame n) :slots)) (defn .slot "Get the value of the nth slot." [&opt nth frame-idx] (in (.slots frame-idx) (or nth 0))) (defn .quit "Resume (dyn :fiber) with the value passed to it after exiting the debugger." [&opt val] (setdyn :exit true) (setdyn :resume-value val) nil) (defn .disasm "Gets the assembly for the current function." [&opt n] (def frame (.frame n)) (def func (frame :function)) (disasm func)) (defn .bytecode "Get the bytecode for the current function." [&opt n] ((.disasm n) 'bytecode)) (defn .ppasm "Pretty prints the assembly for the current function" [&opt n] (def frame (.frame n)) (def func (frame :function)) (def dasm (disasm func)) (def bytecode (dasm 'bytecode)) (def pc (frame :pc)) (def sourcemap (dasm 'sourcemap)) (var last-loc [-2 -2]) (print "\n function: " (dasm 'name) " [" (in dasm 'source "") "]") (when-let [constants (dasm 'constants)] (printf " constants: %.4Q" constants)) (printf " slots: %.4Q\n" (frame :slots)) (def padding (string/repeat " " 20)) (loop [i :range [0 (length bytecode)] :let [instr (bytecode i)]] (prin (if (= (tuple/type instr) :brackets) "*" " ")) (prin (if (= i pc) "> " " ")) (prinf "\e[33m%.20s\e[0m" (string (string/join (map string instr) " ") padding)) (when sourcemap (let [[sl sc] (sourcemap i) loc [sl sc]] (when (not= loc last-loc) (set last-loc loc) (prin " # line " sl ", column " sc)))) (print)) (print)) (defn .source "Show the source code for the function being debugged." [&opt n] (def frame (.frame n)) (def s (frame :source)) (def all-source (slurp s)) (print "\n\e[33m" all-source "\e[0m\n")) (defn .breakall "Set breakpoints on all instructions in the current function." [&opt n] (def fun (.fn n)) (def bytecode (.bytecode n)) (for i 0 (length bytecode) (debug/fbreak fun i)) (print "Set " (length bytecode) " breakpoints in " fun)) (defn .clearall "Clear all breakpoints on the current function." [&opt n] (def fun (.fn n)) (def bytecode (.bytecode n)) (for i 0 (length bytecode) (debug/unfbreak fun i)) (print "Cleared " (length bytecode) " breakpoints in " fun)) (defn .break "Set breakpoint at the current pc." [] (def frame (.frame)) (def fun (frame :function)) (def pc (frame :pc)) (debug/fbreak fun pc) (print "Set breakpoint in " fun " at pc=" pc)) (defn .clear "Clear the current breakpoint" [] (def frame (.frame)) (def fun (frame :function)) (def pc (frame :pc)) (debug/unfbreak fun pc) (print "Cleared breakpoint in " fun " at pc=" pc)) (defn .next "Go to the next breakpoint." [&opt n] (var res nil) (repeat (or n 1) (set res (resume (.fiber)))) res) (defn .nextc "Go to the next breakpoint, clearing the current breakpoint." [&opt n] (.clear) (.next n)) (defn .step "Execute the next n instructions." [&opt n] (var res nil) (repeat (or n 1) (set res (debug/step (.fiber)))) res) janet-1.41.2/examples/echoclient.janet000066400000000000000000000002441514534607600176710ustar00rootroot00000000000000(with [conn (net/connect "127.0.0.1" 8000)] (print "writing abcdefg...") (:write conn "abcdefg") (print "reading...") (printf "got: %v" (:read conn 1024))) janet-1.41.2/examples/echoserve.janet000066400000000000000000000005471514534607600175450ustar00rootroot00000000000000(defn handler "Simple handler for connections." [stream] (defer (:close stream) (def id (gensym)) (def b @"") (print "Connection " id "!") (while (:read stream 1024 b) (printf " %v -> %v" id b) (:write stream b) (buffer/clear b)) (printf "Done %v!" id) (ev/sleep 0.5))) (net/server "127.0.0.1" "8000" handler) janet-1.41.2/examples/error.janet000066400000000000000000000004571514534607600167130ustar00rootroot00000000000000# An example file that errors out. Run with ./janet examples/error.janet # to see stack trace for runtime errors. (defn bork [x] (defn bark [x] (print "Woof!") (print x) (error x) (print "Woof!")) (bark (* 2 x)) (bark (* 3 x))) (defn pupper [] (bork 3) 1) (do (pupper) 1) janet-1.41.2/examples/evlocks.janet000066400000000000000000000015341514534607600172250ustar00rootroot00000000000000(defn sleep "Sleep the entire thread, not just a single fiber." [n] (os/sleep (* 0.1 n))) (defn work [lock n] (ev/acquire-lock lock) (print "working " n "...") (sleep n) (print "done working...") (ev/release-lock lock)) (defn reader [rwlock n] (ev/acquire-rlock rwlock) (print "reading " n "...") (sleep n) (print "done reading " n "...") (ev/release-rlock rwlock)) (defn writer [rwlock n] (ev/acquire-wlock rwlock) (print "writing " n "...") (sleep n) (print "done writing...") (ev/release-wlock rwlock)) (defn test-lock [] (def lock (ev/lock)) (for i 3 7 (ev/spawn-thread (work lock i)))) (defn test-rwlock [] (def rwlock (ev/rwlock)) (for i 0 20 (if (> 0.1 (math/random)) (ev/spawn-thread (writer rwlock i)) (ev/spawn-thread (reader rwlock i))))) (test-rwlock) (test-lock) janet-1.41.2/examples/evsleep.janet000066400000000000000000000006241514534607600172210ustar00rootroot00000000000000(defn worker "Run for a number of iterations." [name iterations] (for i 0 iterations (ev/sleep 1) (print "worker " name " iteration " i))) (ev/call worker :a 10) (ev/sleep 0.2) (ev/call worker :b 5) (ev/sleep 0.3) (ev/call worker :c 12) (defn worker2 [name] (repeat 10 (ev/sleep 0.2) (print name " working"))) (ev/go worker2 :bob) (ev/go worker2 :joe) (ev/go worker2 :sally) janet-1.41.2/examples/ffi/000077500000000000000000000000001514534607600152755ustar00rootroot00000000000000janet-1.41.2/examples/ffi/gtk.janet000066400000000000000000000036361514534607600171150ustar00rootroot00000000000000# :lazy true needed for jpm quickbin # lazily loads library on first function use # so the `main` function # can be marshalled. (ffi/context "/usr/lib/libgtk-3.so" :lazy true) (ffi/defbind gtk-application-new :ptr "Add docstrings as needed." [title :string flags :uint]) (ffi/defbind g-signal-connect-data :ulong [a :ptr b :ptr c :ptr d :ptr e :ptr f :int]) (ffi/defbind g-application-run :int [app :ptr argc :int argv :ptr]) (ffi/defbind gtk-application-window-new :ptr [a :ptr]) (ffi/defbind gtk-button-new-with-label :ptr [a :ptr]) (ffi/defbind gtk-container-add :void [a :ptr b :ptr]) (ffi/defbind gtk-widget-show-all :void [a :ptr]) (ffi/defbind gtk-button-set-label :void [a :ptr b :ptr]) (def cb (delay (ffi/trampoline :default))) (defn ffi/array ``Convert a janet array to a buffer that can be passed to FFI functions. For example, to create an array of type `char *` (array of c strings), one could use `(ffi/array ["hello" "world"] :ptr)`. One needs to be careful that array elements are not garbage collected though - the GC can't follow references inside an arbitrary byte buffer.`` [arr ctype &opt buf] (default buf @"") (each el arr (ffi/write ctype el buf)) buf) (defn on-active [app] (def window (gtk-application-window-new app)) (def btn (gtk-button-new-with-label "Click Me!")) (g-signal-connect-data btn "clicked" (cb) (fn [btn] (gtk-button-set-label btn "Hello World")) nil 1) (gtk-container-add window btn) (gtk-widget-show-all window)) (defn main [&] (def app (gtk-application-new "org.janet-lang.example.HelloApp" 0)) (g-signal-connect-data app "activate" (cb) on-active nil 1) # manually build an array with ffi/write # - we are responsible for preventing gc when the arg array is used (def argv (ffi/array (dyn *args*) :string)) (g-application-run app (length (dyn *args*)) argv)) janet-1.41.2/examples/ffi/so.c000066400000000000000000000076471514534607600161000ustar00rootroot00000000000000#include #include #include #ifdef _WIN32 #define EXPORTER __declspec(dllexport) #else #define EXPORTER #endif /* Structs */ typedef struct { int a, b; float c, d; } Split; typedef struct { float c, d; int a, b; } SplitFlip; typedef struct { int u, v, w, x, y, z; } SixInts; typedef struct { int a; int b; } intint; typedef struct { int a; int b; int c; } intintint; typedef struct { uint64_t a; uint64_t b; } uint64pair; typedef struct { int64_t a; int64_t b; int64_t c; } big; /* Functions */ EXPORTER int int_fn(int a, int b) { return (a << 2) + b; } EXPORTER double my_fn(int64_t a, int64_t b, const char *x) { return (double)(a + b) + 0.5 + strlen(x); } EXPORTER double double_fn(double x, double y, double z) { return (x + y) * z * 3; } EXPORTER double double_many(double x, double y, double z, double w, double a, double b) { return x + y + z + w + a + b; } EXPORTER double double_lots( double a, double b, double c, double d, double e, double f, double g, double h, double i, double j) { return i + j; } EXPORTER double double_lots_2( double a, double b, double c, double d, double e, double f, double g, double h, double i, double j) { return a + 10.0 * b + 100.0 * c + 1000.0 * d + 10000.0 * e + 100000.0 * f + 1000000.0 * g + 10000000.0 * h + 100000000.0 * i + 1000000000.0 * j; } EXPORTER double float_fn(float x, float y, float z) { return (x + y) * z; } EXPORTER int intint_fn(double x, intint ii) { printf("double: %g\n", x); return ii.a + ii.b; } EXPORTER int intintint_fn(double x, intintint iii) { printf("double: %g\n", x); return iii.a + iii.b + iii.c; } EXPORTER intint return_struct(int i) { intint ret; ret.a = i; ret.b = i * i; return ret; } EXPORTER big struct_big(int i, double d) { big ret; ret.a = i; ret.b = (int64_t) d; ret.c = ret.a + ret.b + 1000; return ret; } EXPORTER void void_fn(void) { printf("void fn ran\n"); } EXPORTER void void_fn_2(double y) { printf("y = %f\n", y); } EXPORTER void void_ret_fn(int x) { printf("void fn ran: %d\n", x); } EXPORTER int intintint_fn_2(intintint iii, int i) { fprintf(stderr, "iii.a = %d, iii.b = %d, iii.c = %d, i = %d\n", iii.a, iii.b, iii.c, i); return i * (iii.a + iii.b + iii.c); } EXPORTER float split_fn(Split s) { return s.a * s.c + s.b * s.d; } EXPORTER float split_flip_fn(SplitFlip s) { return s.a * s.c + s.b * s.d; } EXPORTER Split split_ret_fn(int x, float y) { Split ret; ret.a = x; ret.b = x; ret.c = y; ret.d = y; return ret; } EXPORTER SplitFlip split_flip_ret_fn(int x, float y) { SplitFlip ret; ret.a = x; ret.b = x; ret.c = y; ret.d = y; return ret; } EXPORTER SixInts sixints_fn(void) { return (SixInts) { 6666, 1111, 2222, 3333, 4444, 5555 }; } EXPORTER int sixints_fn_2(int x, SixInts s) { return x + s.u + s.v + s.w + s.x + s.y + s.z; } EXPORTER int sixints_fn_3(SixInts s, int x) { return x + s.u + s.v + s.w + s.x + s.y + s.z; } EXPORTER intint stack_spill_fn(uint8_t a, uint8_t b, uint8_t c, uint8_t d, uint8_t e, uint8_t f, uint8_t g, uint8_t h, float i, float j, float k, float l, float m, float n, float o, float p, float s1, int8_t s2, uint8_t s3, double s4, uint8_t s5, intint s6) { return (intint) { (a | b | c | d | e | f | g | h) + (i + j + k + l + m + n + o + p), s1 *s6.a + s2 *s6.b + s3 *s4 *s5 }; } EXPORTER double stack_spill_fn_2(uint64pair a, uint64pair b, uint64pair c, int8_t d, uint64pair e, int8_t f) { return (double)(a.a * c.a + a.b * c.b + b.a * e.a) * f - (double)(b.b * e.b) + d; } janet-1.41.2/examples/ffi/test.janet000066400000000000000000000116401514534607600173010ustar00rootroot00000000000000# # Simple FFI test script that tests against a simple shared object # (def is-windows (= :windows (os/which))) (def ffi/loc (string "examples/ffi/so." (if is-windows "dll" "so"))) (def ffi/source-loc "examples/ffi/so.c") (if is-windows (os/execute ["cl.exe" "/nologo" "/LD" ffi/source-loc "/link" "/DLL" (string "/OUT:" ffi/loc)] :px) (os/execute ["cc" ffi/source-loc "-g" "-shared" "-o" ffi/loc] :px)) (ffi/context ffi/loc) (def intint (ffi/struct :int :int)) (def intintint (ffi/struct :int :int :int)) (def uint64pair (ffi/struct :u64 :u64)) (def big (ffi/struct :s64 :s64 :s64)) (def split (ffi/struct :int :int :float :float)) (def split-flip (ffi/struct :float :float :int :int)) (def six-ints (ffi/struct :int :int :int :int :int :int)) (ffi/defbind int-fn :int [a :int b :int]) (ffi/defbind double-fn :double [a :double b :double c :double]) (ffi/defbind double-many :double [x :double y :double z :double w :double a :double b :double]) (ffi/defbind double-lots :double [a :double b :double c :double d :double e :double f :double g :double h :double i :double j :double]) (ffi/defbind float-fn :double [x :float y :float z :float]) (ffi/defbind intint-fn :int [x :double ii [:int :int]]) (ffi/defbind return-struct [:int :int] [i :int]) (ffi/defbind intintint-fn :int [x :double iii intintint]) (ffi/defbind struct-big big [i :int d :double]) (ffi/defbind void-fn :void []) (ffi/defbind double-lots-2 :double [a :double b :double c :double d :double e :double f :double g :double h :double i :double j :double]) (ffi/defbind void-fn-2 :void [y :double]) (ffi/defbind intintint-fn-2 :int [iii intintint i :int]) (ffi/defbind split-fn :float [s split]) (ffi/defbind split-flip-fn :float [s split-flip]) (ffi/defbind split-ret-fn split [x :int y :float]) (ffi/defbind split-flip-ret-fn split-flip [x :int y :float]) (ffi/defbind sixints-fn six-ints []) (ffi/defbind sixints-fn-2 :int [x :int s six-ints]) (ffi/defbind sixints-fn-3 :int [s six-ints x :int]) (ffi/defbind stack-spill-fn intint [a :u8 b :u8 c :u8 d :u8 e :u8 f :u8 g :u8 h :u8 i :float j :float k :float l :float m :float n :float o :float p :float s1 :float s2 :s8 s3 :u8 s4 :double s5 :u8 s6 intint]) (ffi/defbind stack-spill-fn-2 :double [a uint64pair b uint64pair c uint64pair d :s8 e uint64pair f :s8]) (ffi/defbind-alias int-fn int-fn-aliased :int [a :int b :int]) # # Struct reading and writing # (defn check-round-trip [t value] (def buf (ffi/write t value)) (def same-value (ffi/read t buf)) (assert (deep= value same-value) (string/format "round trip %j (got %j)" value same-value))) (check-round-trip :bool true) (check-round-trip :bool false) (check-round-trip :void nil) (check-round-trip :void nil) (check-round-trip :s8 10) (check-round-trip :s8 0) (check-round-trip :s8 -10) (check-round-trip :u8 10) (check-round-trip :u8 0) (check-round-trip :s16 10) (check-round-trip :s16 0) (check-round-trip :s16 -12312) (check-round-trip :u16 10) (check-round-trip :u16 0) (check-round-trip :u32 0) (check-round-trip :u32 10) (check-round-trip :u32 0xFFFF7777) (check-round-trip :s32 0x7FFF7777) (check-round-trip :s32 0) (check-round-trip :s32 -1234567) (def s (ffi/struct :s8 :s8 :s8 :float)) (check-round-trip s [1 3 5 123.5]) (check-round-trip s [-1 -3 -5 -123.5]) # # Call functions # (tracev (sixints-fn)) (tracev (sixints-fn-2 100 [1 2 3 4 5 6])) (tracev (sixints-fn-3 [1 2 3 4 5 6] 200)) (tracev (split-ret-fn 10 12)) (tracev (split-flip-ret-fn 10 12)) (tracev (split-flip-ret-fn 12 10)) (tracev (intintint-fn-2 [10 20 30] 3)) (tracev (split-fn [5 6 1.2 3.4])) (tracev (void-fn-2 10.3)) (tracev (double-many 1 2 3 4 5 6)) (tracev (string/format "%.17g" (double-many 1 2 3 4 5 6))) (tracev (type (double-many 1 2 3 4 5 6))) (tracev (double-lots-2 0 1 2 3 4 5 6 7 8 9)) (tracev (void-fn)) (tracev (int-fn 10 20)) (tracev (double-fn 1.5 2.5 3.5)) (tracev (double-lots 1 2 3 4 5 6 7 8 9 10)) (tracev (float-fn 8 4 17)) (tracev (intint-fn 123.456 [10 20])) (tracev (intintint-fn 123.456 [10 20 30])) (tracev (return-struct 42)) (tracev (double-lots 1 2 3 4 5 6 700 800 9 10)) (tracev (struct-big 11 99.5)) (tracev (int-fn-aliased 10 20)) (assert (= [10 10 12 12] (split-ret-fn 10 12))) (assert (= [12 12 10 10] (split-flip-ret-fn 10 12))) (assert (= 183 (intintint-fn-2 [10 20 31] 3))) (assert (= 264 (math/round (* 10 (split-fn [5 6 1.2 3.4]))))) (assert (= 9876543210 (double-lots-2 0 1 2 3 4 5 6 7 8 9))) (assert (= 60 (int-fn 10 20))) (assert (= 42 (double-fn 1.5 2.5 3.5))) (assert (= 21 (math/round (double-many 1 2 3 4 5 6.01)))) (assert (= 19 (double-lots 1 2 3 4 5 6 7 8 9 10))) (assert (= 204 (float-fn 8 4 17))) (assert (= [0 38534415] (stack-spill-fn 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1.5 -32 196 65536.5 3 [-15 32]))) (assert (= -2806 (stack-spill-fn-2 [2 3] [5 7] [9 11] -19 [13 17] -23))) (print "Done.") janet-1.41.2/examples/ffi/win32.janet000066400000000000000000000002251514534607600172610ustar00rootroot00000000000000(ffi/context "user32.dll") (ffi/defbind MessageBoxA :int [w :ptr text :string cap :string typ :int]) (MessageBoxA nil "Hello, World!" "Test" 0) janet-1.41.2/examples/fizzbuzz.janet000066400000000000000000000003571514534607600174560ustar00rootroot00000000000000# A simple fizz buzz example (loop [i :range [1 101] :let [fizz (zero? (% i 3)) buzz (zero? (% i 5))]] (print (cond (and fizz buzz) "fizzbuzz" fizz "fizz" buzz "buzz" i))) janet-1.41.2/examples/hello.janet000066400000000000000000000000501514534607600166520ustar00rootroot00000000000000# Prints hello (print "hello, world!") janet-1.41.2/examples/iterate-fiber.janet000066400000000000000000000005721514534607600203020ustar00rootroot00000000000000(def f (coro (for i 0 10 (yield (string "yield " i)) (os/sleep 0)))) (print "simple yielding") (each item f (print "got: " item ", now " (fiber/status f))) (def f (coro (for i 0 10 (yield (string "yield " i)) (ev/sleep 0)))) (print "complex yielding") (each item f (print "got: " item ", now " (fiber/status f))) (print (fiber/status f)) janet-1.41.2/examples/jitfn/000077500000000000000000000000001514534607600156435ustar00rootroot00000000000000janet-1.41.2/examples/jitfn/hello.bin000066400000000000000000000000471514534607600174410ustar00rootroot00000000000000H5Hello, world! janet-1.41.2/examples/jitfn/hello.nasm000066400000000000000000000004351514534607600176300ustar00rootroot00000000000000BITS 64 ;;; ;;; Code ;;; mov rax, 1 ; write( mov rdi, 1 ; STDOUT_FILENO, lea rsi, [rel msg] ; msg, mov rdx, msglen ; sizeof(msg) syscall ; ); ret ; return; ;;; ;;; Constants ;;; msg: db "Hello, world!", 10 msglen: equ $ - msg janet-1.41.2/examples/jitfn/jitfn.janet000066400000000000000000000006301514534607600177770ustar00rootroot00000000000000### ### Relies on NASM being installed to assemble code. ### Only works on x86-64 Linux. ### ### Before running, compile hello.nasm to hello.bin with ### $ nasm hello.nasm -o hello.bin (def bin (slurp "hello.bin")) (def f (ffi/jitfn bin)) (def signature (ffi/signature :default :void)) (ffi/call f signature) (print "called a jitted function with FFI!") (print "machine code: " (describe (string/slice f))) janet-1.41.2/examples/lazyseqs.janet000066400000000000000000000047111514534607600174320ustar00rootroot00000000000000# An example implementation of functional, lazy # sequences, as in clojure. The lazy seq is essentially # A lazy linked list, where the next value is a function # that must be called (realizing it), and the memoized. # Use with (import "./path/to/this/file" :prefix "seq.") (defmacro delay "Lazily evaluate a series of expressions. Returns a function that returns the result of the last expression. Will only evaluate the body once, and then memoizes the result." [& forms] (def state (gensym)) (def loaded (gensym)) ~(do (var ,state nil) (var ,loaded nil) (fn [] (if ,loaded ,state (do (set ,loaded true) (set ,state (do ,;forms))))))) # Use tuples instead of structs to save memory (def- HEAD 0) (def- TAIL 1) (defn empty-seq "The empty sequence." [] nil) (defmacro cons "Create a new sequence by prepending a value to the original sequence." [h t] (def x (tuple h t)) (fn [] x)) (defn empty? "Check if a sequence is empty." [s] (not (s))) (defn head "Get the next value of the sequence." [s] (get (s) HEAD)) (defn tail "Get the rest of a sequence" [s] (get (s) TAIL)) (defn lazy-range "Return a sequence of integers [start, end)." [start end &] (if end (if (< start end) (delay (tuple start (lazy-range (+ 1 start) end))) empty-seq) (lazy-range 0 start))) (defn lazy-map "Return a sequence that is the result of applying f to each value in s." [f s] (delay (def x (s)) (if x (tuple (f (get x HEAD)) (map f (get x TAIL)))))) (defn realize "Force evaluation of a lazy sequence." [s] (when (s) (realize (tail s)))) (defn realize-map "Evaluate f on each member of the sequence. Forces evaluation." [f s] (when (s) (f (head s)) (realize-map f (tail s)))) (defn drop "Ignores the first n values of the sequence and returns the rest." [n s] (delay (def x (s)) (if (and x (pos? n)) ((drop (- n 1) (get x TAIL)))))) (defn take "Returns at most the first n values of s." [n s] (delay (def x (s)) (if (and x (pos? n)) (tuple (get x HEAD) (take (- n 1) (get x TAIL)))))) (defn randseq "Return a sequence of random numbers." [] (delay (tuple (math/random) (randseq)))) (defn take-while "Returns a sequence of values until the predicate is false." [pred s] (delay (def x (s)) (when x (def thehead (get HEAD x)) (if thehead (tuple thehead (take-while pred (get TAIL x))))))) janet-1.41.2/examples/life.janet000066400000000000000000000020371514534607600164750ustar00rootroot00000000000000# A game of life implementation (def- window (seq [x :range [-1 2] y :range [-1 2] :when (not (and (zero? x) (zero? y)))] [x y])) (defn- neighbors [[x y]] (map (fn [[x1 y1]] [(+ x x1) (+ y y1)]) window)) (defn tick "Get the next state in the Game Of Life." [state] (def cell-set (frequencies state)) (def neighbor-set (frequencies (mapcat neighbors state))) (seq [coord :keys neighbor-set :let [count (get neighbor-set coord)] :when (or (= count 3) (and (get cell-set coord) (= count 2)))] coord)) (defn draw "Draw cells in the game of life from (x1, y1) to (x2, y2)" [state x1 y1 x2 y2] (def cellset @{}) (each cell state (put cellset cell true)) (loop [x :range [x1 (+ 1 x2)] :after (print) y :range [y1 (+ 1 y2)]] (file/write stdout (if (get cellset [x y]) "X " ". "))) (print)) # # Run the example # (var *state* '[(0 0) (-1 0) (1 0) (1 1) (0 2)]) (for i 0 20 (print "generation " i) (draw *state* -7 -7 7 7) (set *state* (tick *state*))) janet-1.41.2/examples/lineloop.janet000066400000000000000000000001031514534607600173670ustar00rootroot00000000000000(while (not (empty? (def line (getline)))) (prin "line: " line)) janet-1.41.2/examples/marshal-stress.janet000066400000000000000000000015301514534607600205230ustar00rootroot00000000000000(defn init-db [c] (def res @{:clients @{}}) (var i 0) (repeat c (def n (string "client" i)) (put-in res [:clients n] @{:name n :projects @{}}) (++ i) (repeat c (def pn (string "project" i)) (put-in res [:clients n :projects pn] @{:name pn}) (++ i) (repeat c (def tn (string "task" i)) (put-in res [:clients n :projects pn :tasks tn] @{:name pn}) (++ i)))) res) (loop [c :range [30 80 1]] (var s (os/clock)) (print "Marshal DB with " c " clients, " (* c c) " projects and " (* c c c) " tasks. " "Total " (+ (* c c c) (* c c) c) " tables") (def buf (marshal (init-db c) @{} @"")) (print "Buffer is " (length buf) " bytes") (print "Duration " (- (os/clock) s)) (set s (os/clock)) (gccollect) (print "Collected garbage in " (- (os/clock) s))) janet-1.41.2/examples/maxtriangle.janet000066400000000000000000000006311514534607600200670ustar00rootroot00000000000000# Find the maximum path from the top (root) # of the triangle to the leaves of the triangle. (defn myfold [xs ys] (let [m1 (map + [;xs 0] ys) m2 (map + [0 ;xs] ys)] (map max m1 m2))) (defn maxpath [t] (extreme > (reduce myfold () t))) # Test it # Maximum path is 3 -> 10 -> 3 -> 9 for a total of 25 (def triangle '[[3] [7 10] [4 3 7] [8 9 1 3]]) (print (maxpath triangle)) janet-1.41.2/examples/numarray/000077500000000000000000000000001514534607600163675ustar00rootroot00000000000000janet-1.41.2/examples/numarray/.gitignore000066400000000000000000000000071514534607600203540ustar00rootroot00000000000000/build janet-1.41.2/examples/numarray/numarray.c000066400000000000000000000065711514534607600204020ustar00rootroot00000000000000#include #include typedef struct { double *data; size_t size; } num_array; static num_array *num_array_init(num_array *array, size_t size) { array->data = (double *)janet_calloc(size, sizeof(double)); array->size = size; return array; } static void num_array_deinit(num_array *array) { janet_free(array->data); } static int num_array_gc(void *p, size_t s) { (void) s; num_array *array = (num_array *)p; num_array_deinit(array); return 0; } int num_array_get(void *p, Janet key, Janet *out); void num_array_put(void *p, Janet key, Janet value); static const JanetAbstractType num_array_type = { "numarray", num_array_gc, NULL, num_array_get, num_array_put, JANET_ATEND_PUT }; static Janet num_array_new(int32_t argc, Janet *argv) { janet_fixarity(argc, 1); int32_t size = janet_getinteger(argv, 0); num_array *array = (num_array *)janet_abstract(&num_array_type, sizeof(num_array)); num_array_init(array, size); return janet_wrap_abstract(array); } static Janet num_array_scale(int32_t argc, Janet *argv) { janet_fixarity(argc, 2); num_array *array = (num_array *)janet_getabstract(argv, 0, &num_array_type); double factor = janet_getnumber(argv, 1); size_t i; for (i = 0; i < array->size; i++) { array->data[i] *= factor; } return argv[0]; } static Janet num_array_sum(int32_t argc, Janet *argv) { janet_fixarity(argc, 1); num_array *array = (num_array *)janet_getabstract(argv, 0, &num_array_type); double sum = 0; for (size_t i = 0; i < array->size; i++) sum += array->data[i]; return janet_wrap_number(sum); } void num_array_put(void *p, Janet key, Janet value) { size_t index; num_array *array = (num_array *)p; if (!janet_checkint(key)) janet_panic("expected integer key"); if (!janet_checktype(value, JANET_NUMBER)) janet_panic("expected number value"); index = (size_t)janet_unwrap_integer(key); if (index < array->size) { array->data[index] = janet_unwrap_number(value); } } static Janet num_array_length(int32_t argc, Janet *argv) { janet_fixarity(argc, 1); num_array *array = (num_array *)janet_getabstract(argv, 0, &num_array_type); return janet_wrap_number(array->size); } static const JanetMethod methods[] = { {"scale", num_array_scale}, {"sum", num_array_sum}, {"length", num_array_length}, {NULL, NULL} }; int num_array_get(void *p, Janet key, Janet *out) { size_t index; num_array *array = (num_array *)p; if (janet_checktype(key, JANET_KEYWORD)) return janet_getmethod(janet_unwrap_keyword(key), methods, out); if (!janet_checkint(key)) janet_panic("expected integer key"); index = (size_t)janet_unwrap_integer(key); if (index >= array->size) { return 0; } else { *out = janet_wrap_number(array->data[index]); } return 1; } static const JanetReg cfuns[] = { { "new", num_array_new, "(numarray/new size)\n\n" "Create new numarray" }, { "scale", num_array_scale, "(numarray/scale numarray factor)\n\n" "scale numarray by factor" }, { "sum", num_array_sum, "(numarray/sum numarray)\n\n" "sums numarray" }, {NULL, NULL, NULL} }; JANET_MODULE_ENTRY(JanetTable *env) { janet_cfuns(env, "numarray", cfuns); } janet-1.41.2/examples/numarray/project.janet000066400000000000000000000002261514534607600210600ustar00rootroot00000000000000(declare-project :name "numarray" :description "Example c lib with abstract type") (declare-native :name "numarray" :source @["numarray.c"]) janet-1.41.2/examples/numarray/test/000077500000000000000000000000001514534607600173465ustar00rootroot00000000000000janet-1.41.2/examples/numarray/test/numarray_tests.janet000066400000000000000000000003771514534607600234600ustar00rootroot00000000000000(import /build/numarray) (def a (numarray/new 30)) (print (get a 20)) (print (a 20)) (put a 5 3.14) (print (a 5)) (set (a 5) 100) (print (a 5)) # (numarray/scale a 5)) # ((a :scale) a 5) (:scale a 5) (for i 0 10 (print (a i))) (print "sum=" (:sum a)) janet-1.41.2/examples/posix-exec.janet000066400000000000000000000001461514534607600176410ustar00rootroot00000000000000# Switch to python (print "running in Janet") (os/posix-exec ["python"] :p) (print "will not print") janet-1.41.2/examples/primes.janet000066400000000000000000000006141514534607600170540ustar00rootroot00000000000000# Return an array of primes. This is a trivial and extremely naive algorithm. (defn primes "Returns a list of prime numbers less than n." [n] (def list @[]) (for i 2 n (var isprime? true) (def len (length list)) (for j 0 len (def trial (get list j)) (if (zero? (% i trial)) (set isprime? false))) (if isprime? (array/push list i))) list) (pp (primes 100)) janet-1.41.2/examples/rtest.janet000066400000000000000000000004061514534607600167150ustar00rootroot00000000000000# How random is the RNG really? (def counts (seq [_ :range [0 100]] 0)) (repeat 1000000 (let [x (math/random) intrange (math/floor (* 100 x)) oldcount (counts intrange)] (put counts intrange (if oldcount (+ 1 oldcount) 1)))) (pp counts) janet-1.41.2/examples/sample-bad-bundle1/000077500000000000000000000000001514534607600200665ustar00rootroot00000000000000janet-1.41.2/examples/sample-bad-bundle1/info.jdn000066400000000000000000000000421514534607600215120ustar00rootroot00000000000000@{ :name "sample-bad-bundle1" } janet-1.41.2/examples/sample-bad-bundle2/000077500000000000000000000000001514534607600200675ustar00rootroot00000000000000janet-1.41.2/examples/sample-bad-bundle2/badmod.janet000066400000000000000000000000161514534607600223350ustar00rootroot00000000000000(def abc 123) janet-1.41.2/examples/sample-bad-bundle2/bundle.janet000066400000000000000000000001701514534607600223610ustar00rootroot00000000000000(defn install [manifest &] (bundle/add-file manifest "badmod.janet")) (defn check [&] (error "Check failed!")) janet-1.41.2/examples/sample-bad-bundle2/info.jdn000066400000000000000000000000421514534607600215130ustar00rootroot00000000000000@{ :name "sample-bad-bundle2" } janet-1.41.2/examples/sample-bundle-aliases/000077500000000000000000000000001514534607600207005ustar00rootroot00000000000000janet-1.41.2/examples/sample-bundle-aliases/aliases-mod.janet000066400000000000000000000000311514534607600241130ustar00rootroot00000000000000(defn fun [x] (range x)) janet-1.41.2/examples/sample-bundle-aliases/bundle.janet000066400000000000000000000001171514534607600231730ustar00rootroot00000000000000(defn install [manifest &] (bundle/add-file manifest "aliases-mod.janet")) janet-1.41.2/examples/sample-bundle-aliases/info.jdn000066400000000000000000000001231514534607600223240ustar00rootroot00000000000000@{ :name "sample-bundle-aliases" :dependencies ["sample-dep1" "sample-dep2"] } janet-1.41.2/examples/sample-bundle/000077500000000000000000000000001514534607600172615ustar00rootroot00000000000000janet-1.41.2/examples/sample-bundle/bundle/000077500000000000000000000000001514534607600205325ustar00rootroot00000000000000janet-1.41.2/examples/sample-bundle/bundle/info.jdn000066400000000000000000000001131514534607600221550ustar00rootroot00000000000000@{ :name "sample-bundle" :dependencies ["sample-dep1" "sample-dep2"] } janet-1.41.2/examples/sample-bundle/bundle/init.janet000066400000000000000000000001111514534607600225110ustar00rootroot00000000000000(defn install [manifest &] (bundle/add-file manifest "mymod.janet")) janet-1.41.2/examples/sample-bundle/mymod.janet000066400000000000000000000001371514534607600214320ustar00rootroot00000000000000(import dep1) (import dep2) (defn myfn [x] (def y (dep2/function x)) (dep1/function y)) janet-1.41.2/examples/sample-dep1/000077500000000000000000000000001514534607600166415ustar00rootroot00000000000000janet-1.41.2/examples/sample-dep1/bundle/000077500000000000000000000000001514534607600201125ustar00rootroot00000000000000janet-1.41.2/examples/sample-dep1/bundle/info.jdn000066400000000000000000000001031514534607600215340ustar00rootroot00000000000000@{ :name "sample-dep1" :dependencies [{:name "sample-dep2"}] } janet-1.41.2/examples/sample-dep1/bundle/init.janet000066400000000000000000000001101514534607600220700ustar00rootroot00000000000000(defn install [manifest &] (bundle/add-file manifest "dep1.janet")) janet-1.41.2/examples/sample-dep1/dep1.janet000066400000000000000000000000401514534607600205070ustar00rootroot00000000000000(defn function [x] (+ x x)) janet-1.41.2/examples/sample-dep2/000077500000000000000000000000001514534607600166425ustar00rootroot00000000000000janet-1.41.2/examples/sample-dep2/bundle/000077500000000000000000000000001514534607600201135ustar00rootroot00000000000000janet-1.41.2/examples/sample-dep2/bundle/info.jdn000066400000000000000000000000331514534607600215370ustar00rootroot00000000000000@{ :name "sample-dep2" } janet-1.41.2/examples/sample-dep2/bundle/init.janet000066400000000000000000000001101514534607600220710ustar00rootroot00000000000000(defn install [manifest &] (bundle/add-file manifest "dep2.janet")) janet-1.41.2/examples/sample-dep2/dep2.janet000066400000000000000000000000401514534607600205110ustar00rootroot00000000000000(defn function [x] (* x x)) janet-1.41.2/examples/select.janet000066400000000000000000000007501514534607600170350ustar00rootroot00000000000000(def channels (seq [:repeat 5] (ev/chan 4))) (defn writer [c] (for i 0 3 (def item (string i ":" (mod (hash c) 999))) (ev/sleep 0.1) (print "writer giving item " item " to " c "...") (ev/give c item)) (print "Done!")) (defn reader [name] (forever (def [_ c x] (ev/rselect ;channels)) (print "reader " name " got " x " from " c))) # Readers (each letter [:a :b :c :d :e :f :g] (ev/call reader letter)) # Writers (each c channels (ev/call writer c)) janet-1.41.2/examples/select2.janet000066400000000000000000000011761514534607600171220ustar00rootroot00000000000000### ### examples/select2.janet ### ### Mix reads and writes in select. ### (def c1 (ev/chan 40)) (def c2 (ev/chan 40)) (def c3 (ev/chan 40)) (def c4 (ev/chan 40)) (def c5 (ev/chan 4)) (defn worker [c n x] (forever (ev/sleep n) (ev/give c x))) (defn writer-worker [c] (forever (ev/sleep 0.2) (print "writing " (ev/take c)))) (ev/call worker c1 1 :item1) (ev/sleep 0.2) (ev/call worker c2 1 :item2) (ev/sleep 0.1) (ev/call worker c3 1 :item3) (ev/sleep 0.2) (ev/call worker c4 1 :item4) (ev/sleep 0.1) (ev/call worker c4 1 :item5) (ev/call writer-worker c5) (forever (pp (ev/rselect c1 c2 c3 c4 [c5 :thing]))) janet-1.41.2/examples/sigaction.janet000066400000000000000000000012621514534607600175350ustar00rootroot00000000000000### ### Usage: janet examples/sigaction.janet 1|2|3|4 & ### ### Then at shell: kill -s SIGTERM $! ### (defn action [] (print "Handled SIGTERM!") (flush) (os/exit 1)) (defn main1 [] (os/sigaction :term action true) (forever)) (defn main2 [] (os/sigaction :term action) (forever)) (defn main3 [] (os/sigaction :term action true) (forever (ev/sleep math/inf))) (defn main4 [] (os/sigaction :term action) (forever (ev/sleep math/inf))) (defn main [& args] (def which (scan-number (get args 1 "1"))) (case which 1 (main1) # should work 2 (main2) # will not work 3 (main3) # should work 4 (main4) # should work (error "bad main"))) janet-1.41.2/examples/tcpclient.janet000066400000000000000000000002701514534607600175400ustar00rootroot00000000000000(with [conn (net/connect "127.0.0.1" "8000")] (printf "Connected to %q!" conn) (:write conn "Echo...") (print "Wrote to connection...") (def res (:read conn 1024)) (pp res)) janet-1.41.2/examples/tcpserver.janet000066400000000000000000000010541514534607600175710ustar00rootroot00000000000000(defn handler "Simple handler for connections." [stream] (defer (:close stream) (def id (gensym)) (def b @"") (print "Connection " id "!") (while (:read stream 1024 b) (repeat 10 (print "work for " id " ...") (ev/sleep 0.1)) (:write stream b) (buffer/clear b)) (printf "Done %v!" id))) # Run server. (let [server (net/server "127.0.0.1" "8000")] (print "Starting echo server on 127.0.0.1:8000") (forever (if-let [conn (:accept server)] (ev/call handler conn) (print "no new connections")))) janet-1.41.2/examples/threaded-channels.janet000066400000000000000000000010261514534607600211240ustar00rootroot00000000000000(def chan (ev/thread-chan 10)) (ev/spawn (ev/sleep 0) (print "started fiber!") (ev/give chan (math/random)) (ev/give chan (math/random)) (ev/give chan (math/random)) (ev/sleep 0.5) (repeat 10 (print "giving to channel...") (ev/give chan (math/random)) (ev/sleep 1)) (print "finished fiber!") (:close chan)) (ev/do-thread (print "started thread!") (ev/sleep 1) (while (def x (do (print "taking from channel...") (ev/take chan))) (print "got " x " from thread!")) (print "finished thread!")) janet-1.41.2/examples/udpclient.janet000066400000000000000000000002161514534607600175420ustar00rootroot00000000000000(def conn (net/connect "127.0.0.1" "8009" :datagram)) (:write conn (string/format "%q" (os/cryptorand 16))) (def x (:read conn 1024)) (pp x) janet-1.41.2/examples/udpserver.janet000066400000000000000000000003071514534607600175730ustar00rootroot00000000000000(def server (net/listen "127.0.0.1" "8009" :datagram)) (while true (def buf @"") (def who (:recv-from server 1024 buf)) (printf "got %q from %v, echoing!" buf who) (:send-to server who buf)) janet-1.41.2/examples/urlloader.janet000066400000000000000000000016701514534607600175510ustar00rootroot00000000000000# An example of using Janet's extensible module system to import files from # URL. To try this, run `janet -l ./examples/urlloader.janet` from the command # line, and then at the REPL type: # # (import https://raw.githubusercontent.com/janet-lang/janet/master/examples/colors.janet :as c) # # This will import a file using curl. You can then try: # # (print (c/color :green "Hello!")) # # This is a bit of a toy example (it just shells out to curl), but it is very # powerful and will work well in many cases. (defn- load-url [url args] (def p (os/spawn ["curl" url "-s"] :p {:out :pipe})) (def res (dofile (p :out) :source url ;args)) (:wait p) res) (defn- check-http-url [path] (if (or (string/has-prefix? "http://" path) (string/has-prefix? "https://" path)) path)) # Add the module loader and path tuple to right places (array/push module/paths [check-http-url :janet-http]) (put module/loaders :janet-http load-url) janet-1.41.2/examples/weak-tables.janet000066400000000000000000000007031514534607600177530ustar00rootroot00000000000000(def weak-k (table/weak-keys 10)) (def weak-v (table/weak-values 10)) (def weak-kv (table/weak 10)) (put weak-kv (gensym) 10) (put weak-kv :hello :world) (put weak-k :abc123zz77asda :stuff) (put weak-k true :abc123zz77asda) (put weak-k :zyzzyz false) (put weak-v (gensym) 10) (put weak-v 20 (gensym)) (print "before gc") (tracev weak-k) (tracev weak-v) (tracev weak-kv) (gccollect) (print "after gc") (tracev weak-k) (tracev weak-v) (tracev weak-kv) janet-1.41.2/janet.1000066400000000000000000000205271514534607600141040ustar00rootroot00000000000000.TH JANET 1 .SH NAME janet \- run the Janet language abstract machine .SH SYNOPSIS .B janet [\fB\-hvsrpnqik\fR] [\fB\-e\fR \fISOURCE\fR] [\fB\-E\fR \fISOURCE ...ARGUMENTS\fR] [\fB\-l\fR \fIMODULE\fR] [\fB\-m\fR \fIPATH\fR] [\fB\-c\fR \fIMODULE JIMAGE\fR] [\fB\-w\fR \fILEVEL\fR] [\fB\-x\fR \fILEVEL\fR] [\fB\-\-\fR] .BR script .BR args ... .SH DESCRIPTION Janet is a functional and imperative programming language and bytecode interpreter. It is a Lisp-like language, but lists are replaced by other data structures (arrays, tables, structs, tuples). The language also features bridging to native code written in C, meta-programming with macros, and bytecode assembly. There is a repl for trying out the language, as well as the ability to run script files. This client program is separate from the core runtime, so Janet could be embedded into other programs. Try Janet in your browser at https://janet-lang.org. Implemented in mostly standard C99, Janet runs on Windows, Linux and macOS. The few features that are not standard C99 (dynamic library loading, compiler specific optimizations), are fairly straight forward. Janet can be easily ported to most new platforms. .SH REPL KEY-BINDINGS .TP 16 .BR Home Move cursor to the beginning of input line. .TP 16 .BR End Move cursor to the end of input line. .TP 16 .BR Left/Right Move cursor in input line. .TP 16 .BR Up/Down Go backwards and forwards through history. .TP 16 .BR Tab Complete current symbol, or show available completions. .TP 16 .BR Delete Delete one character after the cursor. .TP 16 .BR Backspace Delete one character before the cursor. .TP 16 .BR Ctrl\-A Move cursor to the beginning of input line. .TP 16 .BR Ctrl\-B Move cursor one character to the left. .TP 16 .BR Ctrl\-D If on a newline, indicate end of stream and exit the repl. .TP 16 .BR Ctrl\-E Move cursor to the end of input line. .TP 16 .BR Ctrl\-F Move cursor one character to the right. .TP 16 .BR Ctrl\-H Delete one character before the cursor. .TP 16 .BR Ctrl\-K Delete everything after the cursor on the input line. .TP 16 .BR Ctrl\-L Clear the screen. .TP 16 .BR Ctrl\-N/Ctrl\-P Go forwards and backwards through history. .TP 16 .BR Ctrl\-U Delete everything before the cursor on the input line. .TP 16 .BR Ctrl\-W Delete one word before the cursor. .TP 16 .BR Ctrl\-G Show documentation for the current symbol under the cursor. .TP 16 .BR Ctrl\-Q Clear the current command, including already typed lines. .TP 16 .BR Alt\-B/Alt\-F Move cursor backwards and forwards one word. .TP 16 .BR Alt\-D Delete one word after the cursor. .TP 16 .BR Alt\-, Go to earliest item in history. .TP 16 .BR Alt\-. Go to last item in history. .LP The repl keybindings are loosely based on a subset of GNU readline, although Janet does not use GNU readline internally for the repl. It is a limited substitute for GNU readline, and does not handle utf-8 input or other mutlibyte input well. To disable the built-in repl input handling, pass the \fB\-s\fR option to Janet, and use a program like rlwrap with Janet to provide input. For key bindings that operate on words, a word is considered to be a sequence of characters that does not contain whitespace. .SH DOCUMENTATION For more complete API documentation, run a REPL (Read Eval Print Loop), and use the doc macro to see documentation on individual bindings. .SH OPTIONS .TP .BR \-h Shows the usage text and exits immediately. .TP .BR \-v Shows the version text and exits immediately. .TP .BR \-s Read raw input from stdin and forgo fancy input, which includes prompt history and other readline-like features. .TP .BR \-e\ code Execute a string of Janet source. Source code is executed in the order it is encountered, so earlier arguments are executed before later ones. .TP .BR \-E\ code\ arguments... Execute a single Janet expression as a Janet short-fn, passing the remaining command line arguments to the expression. This allows more concise one-liners with command line arguments. Example: janet -E '(print $0)' 12 is equivalent to '((short-fn (print $0)) 12)', which is in turn equivalent to `((fn [k] (print k)) 12)` See docs for the `short-fn` function for more details. .TP .BR \-d Enable debug mode. On all terminating signals as well the debug signal, this will cause the debugger to come up in the REPL. Same as calling (setdyn :debug true) in a default repl. .TP .BR \-n Disable ANSI colors in the repl. Has no effect if no repl is run. .TP .BR \-N Enable ANSI colors in the repl. Has no effect if no repl is run. .TP .BR \-r Open a REPL (Read Eval Print Loop) after executing all sources. By default, if Janet is called with no arguments, a REPL is opened. .TP .BR \-R If using the REPL, disable loading the user profile from the JANET_PROFILE environment variable. .TP .BR \-p Turn on the persistent flag. By default, when Janet is executing commands from a file and encounters an error, it will immediately exit after printing the error message. In persistent mode, Janet will keep executing commands after an error. Persistent mode can be good for debugging and testing. .TP .BR \-q Hide the logo in the repl. .TP .BR \-k Don't execute a script, only compile it to check for errors. Useful for linting scripts. .TP .BR \-m\ syspath Set the dynamic binding :syspath to the string syspath so that Janet will load system modules from a directory different than the default. The default is set when Janet is built, and defaults to /usr/local/lib/janet on Linux/Posix. On Windows, there is no default value. This option supersedes JANET_PATH. .TP .BR \-c\ source\ output Precompiles Janet source code into an image, a binary dump that can be efficiently loaded later. Source should be a path to the Janet module to compile, and output should be the file path of resulting image. Output should usually end with the .jimage extension. .TP .BR \-i When this flag is passed, a script passed to the interpreter will be treated as a janet image file rather than a janet source file. .TP .BR \-l\ lib Import a Janet module before running a script or repl. Multiple files can be loaded in this manner, and exports from each file will be made available to the script or repl. .TP .BR \-w\ level Set the warning linting level for Janet. This linting level should be one of :relaxed, :none, :strict, :normal, or a Janet number. Any linting message that is of a greater lint level than this setting will be displayed as a warning, but not stop compilation or execution. .TP .BR \-x\ level Set the error linting level for Janet. This linting level should be one of :relaxed, :none, :strict, :normal, or a Janet number. Any linting message that is of a greater lint level will cause a compilation error and stop compilation. .TP .BR \-\- Stop parsing command line arguments. All arguments after this one will be considered file names and then arguments to the script. .SH ENVIRONMENT .B JANET_PATH .RS The location to look for Janet libraries. This is the only environment variable Janet needs to find native and source code modules. If no JANET_PATH is set, Janet will look in the default location set at compile time. This should be a colon-separated list of directory names on Linux/Posix, and a semicolon-separated list on Windows. Note that a typical setup (i.e. not NixOS / Guix) will only use a single directory. .RE .B JANET_PROFILE .RS Path to a profile file that the interpreter will load before entering the REPL. This profile file will not run for scripts, though. This behavior can be disabled with the -R option. .RE .B JANET_HASHSEED .RS To disable randomization of Janet's PRF on start up, one can set this variable. This can have the effect of making programs deterministic that otherwise would depend on the random seed chosen at program start. This variable does nothing in the default configuration of Janet, as PRF is disabled by default. Also, JANET_REDUCED_OS cannot be defined for this variable to have an effect. .RE .B JANET_HISTFILE .RS A file location to use for the default shell's REPL history when using fancy input. This relative path is where commands are persisted between sessions. If unset, no repl history well be used. Does not work with the -s flag where fancy input is disabled. .RE .B NO_COLOR .RS Turn off color by default in the repl and in the error handler of scripts. This can be changed at runtime via dynamic bindings *err-color* and *pretty-format*, or via the command line parameters -n and -N. .RE .SH AUTHOR Written by Calvin Rose janet-1.41.2/janet_win.rc000066400000000000000000000000411514534607600152120ustar00rootroot00000000000000IDI_MYICON ICON "assets\icon.ico"janet-1.41.2/meson.build000066400000000000000000000265461514534607600150720ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose and contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. project('janet', 'c', default_options : ['c_std=c99', 'build.c_std=c99', 'b_lundef=false', 'default_library=both'], version : '1.41.2') # Global settings janet_path = join_paths(get_option('prefix'), get_option('libdir'), 'janet') header_path = join_paths(get_option('prefix'), get_option('includedir'), 'janet') # Compilers cc = meson.get_compiler('c') native_cc = meson.get_compiler('c', native : true) # Native deps native_m_dep = native_cc.find_library('m', required : false) native_dl_dep = native_cc.find_library('dl', required : false) native_android_spawn_dep = native_cc.find_library('android-spawn', required : false) native_thread_dep = dependency('threads', native : true) # Deps m_dep = cc.find_library('m', required : false) dl_dep = cc.find_library('dl', required : false) # for MINGW/MSYS2 native_ws2_dep = native_cc.find_library('ws2_32', required: false) native_psapi_dep = native_cc.find_library('psapi', required: false) native_wsock_dep = native_cc.find_library('wsock32', required: false) ws2_dep = cc.find_library('ws2_32', required: false) psapi_dep = cc.find_library('psapi', required: false) wsock_dep = cc.find_library('wsock32', required: false) android_spawn_dep = cc.find_library('android-spawn', required : false) thread_dep = dependency('threads') # Link options if get_option('default_library') != 'static' and build_machine.system() != 'windows' add_project_link_arguments('-rdynamic', language : 'c') endif # Generate custom janetconf.h conf = configuration_data() version_parts = meson.project_version().split('.') last_parts = version_parts[2].split('-') if last_parts.length() > 1 conf.set_quoted('JANET_VERSION_EXTRA', '-' + last_parts[1]) else conf.set_quoted('JANET_VERSION_EXTRA', '') endif conf.set('JANET_VERSION_MAJOR', version_parts[0].to_int()) conf.set('JANET_VERSION_MINOR', version_parts[1].to_int()) conf.set('JANET_VERSION_PATCH', last_parts[0].to_int()) conf.set_quoted('JANET_VERSION', meson.project_version()) # Use options conf.set_quoted('JANET_BUILD', get_option('git_hash')) conf.set('JANET_NO_NANBOX', not get_option('nanbox')) conf.set('JANET_SINGLE_THREADED', get_option('single_threaded')) conf.set('JANET_NO_DYNAMIC_MODULES', not get_option('dynamic_modules')) conf.set('JANET_NO_DOCSTRINGS', not get_option('docstrings')) conf.set('JANET_NO_SOURCEMAPS', not get_option('sourcemaps')) conf.set('JANET_NO_ASSEMBLER', not get_option('assembler')) conf.set('JANET_NO_PEG', not get_option('peg')) conf.set('JANET_NO_NET', not get_option('net')) conf.set('JANET_NO_IPV6', not get_option('ipv6')) conf.set('JANET_NO_EV', not get_option('ev') or get_option('single_threaded')) conf.set('JANET_REDUCED_OS', get_option('reduced_os')) conf.set('JANET_NO_INT_TYPES', not get_option('int_types')) conf.set('JANET_PRF', get_option('prf')) conf.set('JANET_RECURSION_GUARD', get_option('recursion_guard')) conf.set('JANET_MAX_PROTO_DEPTH', get_option('max_proto_depth')) conf.set('JANET_MAX_MACRO_EXPAND', get_option('max_macro_expand')) conf.set('JANET_STACK_MAX', get_option('stack_max')) conf.set('JANET_NO_UMASK', not get_option('umask')) conf.set('JANET_NO_REALPATH', not get_option('realpath')) conf.set('JANET_NO_PROCESSES', not get_option('processes')) conf.set('JANET_SIMPLE_GETLINE', get_option('simple_getline')) conf.set('JANET_EV_NO_EPOLL', not get_option('epoll')) conf.set('JANET_EV_NO_KQUEUE', not get_option('kqueue')) conf.set('JANET_NO_INTERPRETER_INTERRUPT', not get_option('interpreter_interrupt')) conf.set('JANET_NO_FFI', not get_option('ffi')) conf.set('JANET_NO_FFI_JIT', not get_option('ffi_jit')) conf.set('JANET_NO_FILEWATCH', not get_option('filewatch')) conf.set('JANET_NO_CRYPTORAND', not get_option('cryptorand')) if get_option('os_name') != '' conf.set('JANET_OS_NAME', get_option('os_name')) endif if get_option('arch_name') != '' conf.set('JANET_ARCH_NAME', get_option('arch_name')) endif if get_option('thread_local_prefix') != '' conf.set('JANET_THREAD_LOCAL', get_option('thread_local_prefix')) endif jconf = configure_file(output : 'janetconf.h', configuration : conf) # Include directories incdir = include_directories(['src/include', '.']) # Order is important here, as some headers # depend on other headers for the amalg target core_headers = [ 'src/core/features.h', 'src/core/util.h', 'src/core/state.h', 'src/core/gc.h', 'src/core/vector.h', 'src/core/fiber.h', 'src/core/regalloc.h', 'src/core/compile.h', 'src/core/emit.h', 'src/core/symcache.h' ] core_src = [ 'src/core/abstract.c', 'src/core/array.c', 'src/core/asm.c', 'src/core/buffer.c', 'src/core/bytecode.c', 'src/core/capi.c', 'src/core/cfuns.c', 'src/core/compile.c', 'src/core/corelib.c', 'src/core/debug.c', 'src/core/emit.c', 'src/core/ev.c', 'src/core/ffi.c', 'src/core/fiber.c', 'src/core/filewatch.c', 'src/core/gc.c', 'src/core/inttypes.c', 'src/core/io.c', 'src/core/marsh.c', 'src/core/math.c', 'src/core/net.c', 'src/core/os.c', 'src/core/parse.c', 'src/core/peg.c', 'src/core/pp.c', 'src/core/regalloc.c', 'src/core/run.c', 'src/core/specials.c', 'src/core/state.c', 'src/core/string.c', 'src/core/strtod.c', 'src/core/struct.c', 'src/core/symcache.c', 'src/core/table.c', 'src/core/tuple.c', 'src/core/util.c', 'src/core/value.c', 'src/core/vector.c', 'src/core/vm.c', 'src/core/wrap.c' ] boot_src = [ 'src/boot/array_test.c', 'src/boot/boot.c', 'src/boot/buffer_test.c', 'src/boot/number_test.c', 'src/boot/system_test.c', 'src/boot/table_test.c', ] mainclient_src = [ 'src/mainclient/shell.c' ] janet_dependencies = [m_dep, dl_dep, android_spawn_dep, ws2_dep, psapi_dep, wsock_dep] janet_native_dependencies = [native_m_dep, native_dl_dep, native_android_spawn_dep, native_ws2_dep, native_psapi_dep, native_wsock_dep] if not get_option('single_threaded') janet_dependencies += thread_dep janet_native_dependencies += native_thread_dep endif # Build boot binary janet_boot = executable('janet-boot', core_src, boot_src, include_directories : incdir, c_args : '-DJANET_BOOTSTRAP', dependencies : janet_native_dependencies, native : true) # Build janet.c janetc = custom_target('janetc', input : [janet_boot, 'src/boot/boot.janet'], output : 'janet.c', capture : true, command : [ janet_boot, meson.current_source_dir(), 'JANET_PATH', janet_path ]) # Allow building with no shared library if cc.has_argument('-fvisibility=hidden') lib_cflags = ['-fvisibility=hidden'] else lib_cflags = [] endif if get_option('shared') libjanet = library('janet', janetc, include_directories : incdir, dependencies : janet_dependencies, version: meson.project_version(), soversion: version_parts[0] + '.' + version_parts[1], c_args : lib_cflags, install : true) # Extra c flags - adding -fvisibility=hidden matches the Makefile and # shaves off about 10k on linux x64, likely similar on other platforms. if cc.has_argument('-fvisibility=hidden') extra_cflags = ['-fvisibility=hidden', '-DJANET_DLL_IMPORT'] else extra_cflags = ['-DJANET_DLL_IMPORT'] endif janet_mainclient = executable('janet', mainclient_src, include_directories : incdir, dependencies : janet_dependencies, link_with: [libjanet], c_args : extra_cflags, install : true) else # No shared library janet_mainclient = executable('janet', mainclient_src, janetc, include_directories : incdir, dependencies : janet_dependencies, c_args : lib_cflags, install : true) endif if meson.is_cross_build() native_cc = meson.get_compiler('c', native: true) if native_cc.has_argument('-fvisibility=hidden') extra_native_cflags = ['-fvisibility=hidden'] else extra_native_cflags = [] endif janet_nativeclient = executable('janet-native', janetc, mainclient_src, include_directories : incdir, dependencies : janet_native_dependencies, c_args : extra_native_cflags, native : true) else janet_nativeclient = janet_mainclient endif # Documentation docs = custom_target('docs', input : ['tools/gendoc.janet'], output : ['doc.html'], capture : true, command : [janet_nativeclient, '@INPUT@']) # Tests test_files = [ 'test/suite-array.janet', 'test/suite-asm.janet', 'test/suite-boot.janet', 'test/suite-buffer.janet', 'test/suite-bundle.janet', 'test/suite-capi.janet', 'test/suite-cfuns.janet', 'test/suite-compile.janet', 'test/suite-corelib.janet', 'test/suite-debug.janet', 'test/suite-ev.janet', 'test/suite-ev2.janet', 'test/suite-ffi.janet', 'test/suite-filewatch.janet', 'test/suite-inttypes.janet', 'test/suite-io.janet', 'test/suite-marsh.janet', 'test/suite-math.janet', 'test/suite-net.janet', 'test/suite-os.janet', 'test/suite-parse.janet', 'test/suite-peg.janet', 'test/suite-pp.janet', 'test/suite-specials.janet', 'test/suite-string.janet', 'test/suite-strtod.janet', 'test/suite-struct.janet', 'test/suite-symcache.janet', 'test/suite-table.janet', 'test/suite-tuple.janet', 'test/suite-unknown.janet', 'test/suite-value.janet', 'test/suite-vm.janet' ] foreach t : test_files test(t, janet_nativeclient, args : files([t]), workdir : meson.current_source_dir()) endforeach # Repl run_target('repl', command : [janet_nativeclient]) # For use as meson subproject (wrap) if get_option('shared') janet_dep = declare_dependency(include_directories : incdir, link_with : libjanet) # pkgconfig pkg = import('pkgconfig') pkg.generate(libjanet, subdirs: 'janet', description: 'Library for the Janet programming language.') endif # Installation install_man('janet.1') install_data(sources : ['tools/.keep'], install_dir : join_paths(get_option('libdir'), 'janet')) patched_janet = custom_target('patched-janeth', input : ['tools/patch-header.janet', 'src/include/janet.h', jconf], install : true, install_dir : join_paths(get_option('includedir'), 'janet'), build_by_default : true, output : ['janet_' + meson.project_version() + '.h'], command : [janet_nativeclient, '@INPUT@', '@OUTPUT@']) # Create a version of the janet.h header that matches what jpm often expects if meson.version().version_compare('>=0.61') install_symlink('janet.h', pointing_to: 'janet/janet_' + meson.project_version() + '.h', install_dir: get_option('includedir')) install_symlink('janet.h', pointing_to: 'janet_' + meson.project_version() + '.h', install_dir: join_paths(get_option('includedir'), 'janet')) endif janet-1.41.2/meson_options.txt000066400000000000000000000034251514534607600163540ustar00rootroot00000000000000option('git_hash', type : 'string', value : 'meson') option('single_threaded', type : 'boolean', value : false) option('nanbox', type : 'boolean', value : true) option('dynamic_modules', type : 'boolean', value : true) option('docstrings', type : 'boolean', value : true) option('sourcemaps', type : 'boolean', value : true) option('reduced_os', type : 'boolean', value : false) option('assembler', type : 'boolean', value : true) option('peg', type : 'boolean', value : true) option('int_types', type : 'boolean', value : true) option('prf', type : 'boolean', value : false) option('net', type : 'boolean', value : true) option('ipv6', type : 'boolean', value : true) option('ev', type : 'boolean', value : true) option('processes', type : 'boolean', value : true) option('umask', type : 'boolean', value : true) option('realpath', type : 'boolean', value : true) option('simple_getline', type : 'boolean', value : false) option('epoll', type : 'boolean', value : true) option('kqueue', type : 'boolean', value : true) option('interpreter_interrupt', type : 'boolean', value : true) option('ffi', type : 'boolean', value : true) option('ffi_jit', type : 'boolean', value : true) option('filewatch', type : 'boolean', value : true) option('recursion_guard', type : 'integer', min : 10, max : 8000, value : 1024) option('max_proto_depth', type : 'integer', min : 10, max : 8000, value : 200) option('max_macro_expand', type : 'integer', min : 1, max : 8000, value : 200) option('stack_max', type : 'integer', min : 8096, max : 0x7fffffff, value : 0x7fffffff) option('arch_name', type : 'string', value: '') option('thread_local_prefix', type : 'string', value: '') option('os_name', type : 'string', value: '') option('shared', type : 'boolean', value: true) option('cryptorand', type : 'boolean', value: true) janet-1.41.2/plan9.mk000077500000000000000000000035621514534607600143000ustar00rootroot00000000000000$target build/janet.$O: build/c/janet.c src/conf/janetconf.h src/include/janet.h $CC $CFLAGS -D^$JANET_CONFIG -o $target $prereq(1) build/shell.$O: src/mainclient/shell.c src/conf/janetconf.h src/include/janet.h $CC $CFLAGS -D^$JANET_CONFIG -o $target $prereq(1) #include #include "tests.h" int array_test() { int i; JanetArray *array1, *array2; array1 = janet_array(10); array2 = janet_array(0); janet_array_push(array1, janet_cstringv("one")); janet_array_push(array1, janet_cstringv("two")); janet_array_push(array1, janet_cstringv("three")); janet_array_push(array1, janet_cstringv("four")); janet_array_push(array1, janet_cstringv("five")); janet_array_push(array1, janet_cstringv("six")); janet_array_push(array1, janet_cstringv("seven")); assert(array1->count == 7); assert(array1->capacity >= 7); assert(janet_equals(array1->data[0], janet_cstringv("one"))); janet_array_push(array2, janet_cstringv("one")); janet_array_push(array2, janet_cstringv("two")); janet_array_push(array2, janet_cstringv("three")); janet_array_push(array2, janet_cstringv("four")); janet_array_push(array2, janet_cstringv("five")); janet_array_push(array2, janet_cstringv("six")); janet_array_push(array2, janet_cstringv("seven")); for (i = 0; i < array2->count; i++) { assert(janet_equals(array1->data[i], array2->data[i])); } janet_array_pop(array1); janet_array_pop(array1); assert(array1->count == 5); return 0; } janet-1.41.2/src/boot/boot.c000066400000000000000000000066551514534607600155700ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #include #include "tests.h" #ifdef JANET_WINDOWS #include #define chdir(x) _chdir(x) #else #include #endif extern const unsigned char *janet_gen_boot; extern int32_t janet_gen_boot_size; int main(int argc, const char **argv) { /* Init janet */ janet_init(); /* Run tests */ array_test(); buffer_test(); number_test(); system_test(); table_test(); /* C tests passed */ /* Set up VM */ int status; JanetTable *env; env = janet_core_env(NULL); /* Create args tuple */ JanetArray *args = janet_array(argc); for (int i = 0; i < argc; i++) janet_array_push(args, janet_cstringv(argv[i])); janet_def(env, "boot/args", janet_wrap_array(args), "Command line arguments."); /* Add in options from janetconf.h so boot.janet can configure the image as needed. */ JanetTable *opts = janet_table(0); #ifdef JANET_NO_DOCSTRINGS janet_table_put(opts, janet_ckeywordv("no-docstrings"), janet_wrap_true()); #endif #ifdef JANET_NO_SOURCEMAPS janet_table_put(opts, janet_ckeywordv("no-sourcemaps"), janet_wrap_true()); #endif janet_def(env, "boot/config", janet_wrap_table(opts), "Boot options"); /* Run bootstrap script to generate core image */ const char *boot_filename; #ifdef JANET_NO_SOURCEMAPS boot_filename = NULL; #else boot_filename = "boot.janet"; #endif int chdir_status = chdir(argv[1]); if (chdir_status) { fprintf(stderr, "Could not change to directory %s\n", argv[1]); exit(1); } FILE *boot_file = fopen("src/boot/boot.janet", "rb"); if (NULL == boot_file) { fprintf(stderr, "Could not open src/boot/boot.janet\n"); exit(1); } /* Slurp file into buffer */ fseek(boot_file, 0, SEEK_END); size_t boot_size = ftell(boot_file); fseek(boot_file, 0, SEEK_SET); unsigned char *boot_buffer = janet_malloc(boot_size); if (NULL == boot_buffer) { fprintf(stderr, "Failed to allocate boot buffer\n"); exit(1); } if (!fread(boot_buffer, 1, boot_size, boot_file)) { fprintf(stderr, "Failed to read into boot buffer\n"); exit(1); } fclose(boot_file); status = janet_dobytes(env, boot_buffer, (int32_t) boot_size, boot_filename, NULL); janet_free(boot_buffer); /* Deinitialize vm */ janet_deinit(); return status; } janet-1.41.2/src/boot/boot.janet000066400000000000000000005003741514534607600164440ustar00rootroot00000000000000# The core janet library # Copyright 2026 © Calvin Rose ### ### ### Macros and Basic Functions ### ### (def defn :macro :flycheck ``` (defn name & more) Define a function. Equivalent to `(def name (fn name [args] ...))`. ``` (fn defn [name & more] (def len (length more)) (def modifiers @[]) (var docstr "") (def fstart (fn recur [i] (def {i ith} more) (def t (type ith)) (if (= t :tuple) i (do (if (= t :string) (set docstr ith) (array/push modifiers ith)) (if (< i len) (recur (+ i 1))))))) (def start (fstart 0)) (def args (in more start)) # Add function signature to docstring (var index 0) (def arglen (length args)) (def buf (buffer "(" name)) (while (< index arglen) (buffer/push-string buf " ") (buffer/format buf "%j" (in args index)) (set index (+ index 1))) (array/push modifiers (string buf ")\n\n" docstr)) (if (dyn :debug) (array/push modifiers {:source-form (dyn :macro-form)})) # Build return value ~(def ,name ,;modifiers (fn ,name ,;(tuple/slice more start))))) (defn defmacro :macro :flycheck "Define a macro." [name & more] (setdyn name @{}) # override old macro definitions in the case of a recursive macro (apply defn name :macro more)) (defmacro as-macro ``Use a function or macro literal `f` as a macro. This lets any function be used as a macro. Inside a quasiquote, the idiom `(as-macro ,my-custom-macro arg1 arg2...)` can be used to avoid unwanted variable capture of `my-custom-macro`.`` [f & args] (f ;args)) (defmacro defmacro- :flycheck "Define a private macro that will not be exported." [name & more] (apply defn name :macro :private more)) (defmacro defn- :flycheck "Define a private function that will not be exported." [name & more] (apply defn name :private more)) (defmacro def- "Define a private value that will not be exported." [name & more] ~(def ,name :private ,;more)) (defmacro var- "Define a private var that will not be exported." [name & more] ~(var ,name :private ,;more)) (defmacro toggle "Set a value to its boolean inverse. Same as `(set value (not value))`." [value] ~(set ,value (,not ,value))) (defn defglobal "Dynamically create a global def." [name value] (def name* (symbol name)) (setdyn name* @{:value value}) nil) (defn varglobal "Dynamically create a global var." [name init] (def name* (symbol name)) (setdyn name* @{:ref @[init]}) nil) # Basic predicates (defn nan? "Check if x is NaN." [x] (not= x x)) (defn number? "Check if x is a number." [x] (= (type x) :number)) (defn fiber? "Check if x is a fiber." [x] (= (type x) :fiber)) (defn string? "Check if x is a string." [x] (= (type x) :string)) (defn symbol? "Check if x is a symbol." [x] (= (type x) :symbol)) (defn keyword? "Check if x is a keyword." [x] (= (type x) :keyword)) (defn buffer? "Check if x is a buffer." [x] (= (type x) :buffer)) (defn function? "Check if x is a function (not a cfunction)." [x] (= (type x) :function)) (defn cfunction? "Check if x is a cfunction." [x] (= (type x) :cfunction)) (defn table? "Check if x is a table." [x] (= (type x) :table)) (defn struct? "Check if x is a struct." [x] (= (type x) :struct)) (defn array? "Check if x is an array." [x] (= (type x) :array)) (defn tuple? "Check if x is a tuple." [x] (= (type x) :tuple)) (defn boolean? "Check if x is a boolean." [x] (= (type x) :boolean)) (defn truthy? "Check if x is truthy." [x] (if x true false)) (defn true? "Check if x is true." [x] (= x true)) (defn false? "Check if x is false." [x] (= x false)) (defn nil? "Check if x is nil." [x] (= x nil)) (defn empty? "Check if an iterable, `iter`, is empty." [iter] (= nil (next iter nil))) # For macros, we define an incomplete odd? function that will be overridden. (defn odd? [x] (= 1 (mod x 2))) (def- non-atomic-types {:array true :tuple true :table true :buffer true :symbol true :struct true}) (defn idempotent? "Check if x is a value that evaluates to itself when compiled." [x] (not (in non-atomic-types (type x)))) # C style macros and functions for imperative sugar. No bitwise though. (defn inc "Returns x + 1." [x] (+ x 1)) (defn dec "Returns x - 1." [x] (- x 1)) (defmacro ++ "Increments the var x by 1." [x] ~(set ,x (,+ ,x ,1))) (defmacro -- "Decrements the var x by 1." [x] ~(set ,x (,- ,x ,1))) (defmacro += "Increments the var x by n." [x & ns] ~(set ,x (,+ ,x ,;ns))) (defmacro -= "Decrements the var x by n." [x & ns] ~(set ,x (,- ,x ,;ns))) (defmacro *= "Shorthand for (set x (\\* x n))." [x & ns] ~(set ,x (,* ,x ,;ns))) (defmacro /= "Shorthand for (set x (/ x n))." [x & ns] ~(set ,x (,/ ,x ,;ns))) (defmacro %= "Shorthand for (set x (% x n))." [x & ns] ~(set ,x (,% ,x ,;ns))) (defmacro assert :flycheck # should top level assert flycheck? "Throw an error if x is not truthy. Will not evaluate `err` if x is truthy." [x &opt err] (def v (gensym)) ~(do (def ,v ,x) (if ,v ,v (,error ,(if err err (string/format "assert failure in %j" x)))))) (defmacro defdyn :flycheck ``Define an alias for a keyword that is used as a dynamic binding. The alias is a normal, lexically scoped binding that can be used instead of a keyword to prevent typos. `defdyn` does not set dynamic bindings or otherwise replace `dyn` and `setdyn`. The alias *must* start and end with the `*` character, usually called "earmuffs".`` [alias & more] (assert (symbol? alias) "alias must be a symbol") (assert (> (length alias) 2) "name must have leading and trailing '*' characters") (assert (= 42 (get alias 0) (get alias (- (length alias) 1))) "name must have leading and trailing '*' characters") (def prefix (dyn :defdyn-prefix)) (def kw (keyword prefix (slice alias 1 -2))) ~(def ,alias :dyn ,;more ,kw)) (defdyn *macro-form* "Inside a macro, is bound to the source form that invoked the macro") (defdyn *flychecking* "Check if the current form is being evaluated inside `flycheck`. Will be `true` while flychecking.") (defdyn *lint-error* "The current lint error level. The error level is the lint level at which compilation will exit with an error and not continue.") (defdyn *lint-warn* "The current lint warning level. The warning level is the lint level at which and error will be printed but compilation will continue as normal.") (defdyn *lint-levels* "A table of keyword alias to numbers denoting a lint level. Can be used to provided custom aliases for numeric lint levels.") (defdyn *macro-lints* ``Bound to an array of lint messages that will be reported by the compiler inside a macro. To indicate an error or warning, a macro author should use `maclintf`.``) (defn maclintf ``When inside a macro, call this function to add a linter warning. Takes a `fmt` argument like `string/format`, which is used to format the message.`` [level fmt & args] (def lints (dyn *macro-lints*)) (if lints (do (def form (dyn *macro-form*)) (def [l c] (if (tuple? form) (tuple/sourcemap form) [nil nil])) (def l (if (not= -1 l) l)) (def c (if (not= -1 c) c)) (def msg (string/format fmt ;args)) (array/push lints [level l c msg]))) nil) (defn errorf "A combination of `error` and `string/format`. Equivalent to `(error (string/format fmt ;args))`." [fmt & args] (error (string/format fmt ;args))) (defmacro assertf "Convenience macro that combines `assert` and `string/format`." [x fmt & args] (def v (gensym)) ~(do (def ,v ,x) (if ,v ,v (,errorf ,fmt ,;args)))) (defmacro default ``Define a default value for an optional argument. Expands to `(def sym (if (= nil sym) val sym))`.`` [sym val] ~(def ,sym (if (,= nil ,sym) ,val ,sym))) (defmacro comment "Ignores the body of the comment." [&]) (defmacro if-not "Shorthand for `(if (not condition) else then)`." [condition then &opt else] ~(if ,condition ,else ,then)) (defmacro when "Evaluates the body when the condition is true. Otherwise returns nil." [condition & body] ~(if ,condition (do ,;body))) (defmacro unless "Shorthand for `(when (not condition) ;body)`. " [condition & body] ~(if ,condition nil (do ,;body))) (defmacro cond `Evaluates conditions sequentially until the first true condition is found, and then executes the corresponding body. If there are an odd number of forms, and no forms are matched, the last expression is executed. If there are no matches, returns nil.` [& pairs] (defn aux [i] (def restlen (- (length pairs) i)) (if (= restlen 0) nil (if (= restlen 1) (in pairs i) (tuple 'if (in pairs i) (in pairs (+ i 1)) (aux (+ i 2)))))) (aux 0)) (defmacro case ``Select the body that equals the dispatch value. When `pairs` has an odd number of elements, the last is the default expression. If no match is found, returns nil.`` [dispatch & pairs] (def atm (idempotent? dispatch)) (def sym (if atm dispatch (gensym))) (defn aux [i] (def restlen (- (length pairs) i)) (if (= restlen 0) nil (if (= restlen 1) (in pairs i) (tuple 'if (tuple = sym (in pairs i)) (in pairs (+ i 1)) (aux (+ i 2)))))) (if atm (aux 0) (tuple 'do (tuple 'def sym dispatch) (aux 0)))) (defmacro let ``Create a scope and bind values to symbols. Each pair in `bindings` is assigned as if with `def`, and the body of the `let` form returns the last value.`` [bindings & body] (if (odd? (length bindings)) (error "expected even number of bindings to let")) (def len (length bindings)) (var i 0) (var accum @['do]) (while (< i len) (def {i k (+ i 1) v} bindings) (array/push accum (tuple 'def k v)) (+= i 2)) (array/concat accum body) (tuple/slice accum 0)) (defmacro protect `Evaluate expressions, while capturing any errors. Evaluates to a tuple of two elements. The first element is true if successful, false if an error, and the second is the return value or error.` [& body] (let [f (gensym) r (gensym)] ~(let [,f (,fiber/new (fn :protect [] ,;body) :ie) ,r (,resume ,f)] [(,not= :error (,fiber/status ,f)) ,r]))) (defmacro and `Evaluates to the last argument if all preceding elements are truthy, otherwise evaluates to the first falsey argument.` [& forms] (var ret true) (def len (length forms)) (var i len) (while (> i 0) (-- i) (def v (in forms i)) (set ret (if (= i (- len 1)) v (if (idempotent? v) ['if v ret v] (do (def s (gensym)) ['if ['def s v] ret s]))))) ret) (defmacro or `Evaluates to the last argument if all preceding elements are falsey, otherwise evaluates to the first truthy element.` [& forms] (def len (length forms)) (var i (- len 1)) (var ret (get forms i)) (while (> i 0) (-- i) (def fi (in forms i)) (set ret (if (idempotent? fi) (tuple 'if fi fi ret) (do (def $fi (gensym)) (tuple 'do (tuple 'def $fi fi) (tuple 'if $fi $fi ret)))))) ret) (defmacro try ``Try something and catch errors. `body` is any expression, and `catch` should be a form, the first element of which is a tuple. This tuple should contain a binding for errors and an optional binding for the fiber wrapping the body. Returns the result of `body` if no error, or the result of `catch` if an error.`` [body catch] (assert (and (not (empty? catch)) (indexed? (catch 0))) "the first element of `catch` must be a tuple or array") (let [[err fib] (catch 0) r (gensym) f (gensym)] ~(let [,f (,fiber/new (fn :try [] ,body) :ie) ,r (,resume ,f)] (if (,= (,fiber/status ,f) :error) (do ,(if err ~(def ,err ,r)) ,(if fib ~(def ,fib ,f)) ,;(tuple/slice catch 1)) ,r)))) (defmacro with-syms "Evaluates `body` with each symbol in `syms` bound to a generated, unique symbol." [syms & body] (var i 0) (def len (length syms)) (def accum @[]) (while (< i len) (array/push accum (in syms i) [gensym]) (++ i)) ~(let (,;accum) ,;body)) (defn- defer-impl "Defer but allow custom name for stack traces" [name form body] (with-syms [f r] ~(do (def ,f (,fiber/new (fn ,name [] ,;body) :ti)) (def ,r (,resume ,f)) ,form (if (= (,fiber/status ,f) :dead) ,r (,propagate ,r ,f))))) (defmacro defer ``Run `form` unconditionally after `body`, even if the body throws an error. Will also run `form` if a user signal 0-4 is received.`` [form & body] (defer-impl :defer form body)) (defmacro edefer ``Run `form` after `body` in the case that body terminates abnormally (an error or user signal 0-4). Otherwise, return last form in `body`.`` [form & body] (with-syms [f r] ~(do (def ,f (,fiber/new (fn :edefer [] ,;body) :ti)) (def ,r (,resume ,f)) (if (= (,fiber/status ,f) :dead) ,r (do ,form (,propagate ,r ,f)))))) (defmacro prompt ``Set up a checkpoint that can be returned to. `tag` should be a value that is used in a `return` statement, like a keyword.`` [tag & body] (with-syms [res target payload fib] ~(do (def ,fib (,fiber/new (fn :prompt [] [,tag (do ,;body)]) :i0)) (def ,res (,resume ,fib)) (def [,target ,payload] ,res) (if (,= ,tag ,target) ,payload (,propagate ,res ,fib))))) (defmacro chr `Convert a string of length 1 to its byte (ascii) value at compile time.` [c] (unless (and (string? c) (= (length c) 1)) (error (string/format "expected string of length 1, got %v" c))) (c 0)) (defmacro label ``Set a label point that is lexically scoped. `name` should be a symbol that will be bound to the label.`` [name & body] ~(do (def ,name @"") ,(apply prompt name body))) (defn return "Return to a prompt point." [to &opt value] (signal 0 [to value])) (defmacro with ``Evaluate `body` with some resource, which will be automatically cleaned up if there is an error in `body`. `binding` is bound to the expression `ctor`, and `dtor` is a function or callable that is passed the binding. If no destructor (`dtor`) is given, will call :close on the resource.`` [[binding ctor dtor] & body] ~(do (def ,binding ,ctor) ,(defer-impl :with [(or dtor :close) binding] body))) (defmacro when-with ``Similar to with, but if binding is false or nil, returns nil without evaluating the body. Otherwise, the same as `with`.`` [[binding ctor dtor] & body] ~(if-let [,binding ,ctor] ,(defer-impl :when-with [(or dtor :close) binding] body))) (defmacro if-with ``Similar to `with`, but if binding is false or nil, evaluates the falsey path. Otherwise, evaluates the truthy path. In both cases, `ctor` is bound to binding.`` [[binding ctor dtor] truthy &opt falsey] ~(if-let [,binding ,ctor] ,(defer-impl :if-with [(or dtor :close) binding] [truthy]) ,falsey)) (defn- for-var-template [i start stop step comparison delta body] (with-syms [s] (def st (if (idempotent? step) step (gensym))) (def loop-body ~(while (,comparison ,i ,s) ,;body (set ,i (,delta ,i ,st)))) ~(do (var ,i ,start) (def ,s ,stop) ,;(if (= st step) [] [~(def ,st ,step)]) ,(if (and (number? st) (> st 0)) loop-body ~(if (,> ,st 0) ,loop-body))))) (defn- for-template [binding start stop step comparison delta body] (def i (gensym)) (for-var-template i start stop step comparison delta [~(def ,binding ,i) ;body])) (defn- check-indexed [x] (if (indexed? x) x (error (string "expected tuple for range, got " x)))) (defn- range-template [binding object kind rest op comparison] (check-indexed object) (def [a b c] object) (def [start stop step] (case (length object) 1 (case kind :range [0 a 1] :down [a 0 1]) 2 [a b 1] [a b c])) (for-template binding start stop step comparison op [rest])) (defn- each-template [binding inx kind body] (with-syms [k] (def ds (if (idempotent? inx) inx (gensym))) ~(do ,(unless (= ds inx) ~(def ,ds ,inx)) (var ,k (,next ,ds nil)) (while (,not= nil ,k) (def ,binding ,(case kind :each ~(,in ,ds ,k) :keys k :pairs ~[,k (,in ,ds ,k)])) ,;body (set ,k (,next ,ds ,k)))))) (defn- iterate-template [binding expr body] (with-syms [i] ~(do (var ,i nil) (while (set ,i ,expr) (def ,binding ,i) ,body)))) (defn- loop1 [body head i] # Terminate recursion (when (<= (length head) i) (break ~(do ,;body))) (def {i binding (+ i 1) verb} head) # 2 term expression (when (keyword? binding) (break (let [rest (loop1 body head (+ i 2))] (case binding :until ~(do (if ,verb (break) nil) ,rest) :while ~(do (if ,verb nil (break)) ,rest) :let ~(let ,verb (do ,rest)) :after ~(do ,rest ,verb nil) :before ~(do ,verb ,rest nil) :repeat (with-syms [iter] ~(do (var ,iter ,verb) (while (> ,iter 0) ,rest (-- ,iter)))) :when ~(when ,verb ,rest) :unless ~(unless ,verb ,rest) (error (string "unexpected loop modifier " binding)))))) # 3 term expression (def {(+ i 2) object} head) (let [rest (loop1 body head (+ i 3))] (case verb :range (range-template binding object :range rest + <) :range-to (range-template binding object :range rest + <=) :down (range-template binding object :down rest - >) :down-to (range-template binding object :down rest - >=) :keys (each-template binding object :keys [rest]) :pairs (each-template binding object :pairs [rest]) :in (each-template binding object :each [rest]) :iterate (iterate-template binding object rest) (error (string "unexpected loop verb " verb))))) (defmacro forv ``Do a C-style for-loop for side effects. The iteration variable `i` can be mutated in the loop, unlike normal `for`. Returns nil.`` [i start stop & body] (for-var-template i start stop 1 < + body)) (defmacro for "Do a C-style for-loop for side effects. Returns nil." [i start stop & body] (for-template i start stop 1 < + body)) (defmacro eachk "Loop over each key in `ds`. Returns nil." [x ds & body] (each-template x ds :keys body)) (defmacro eachp "Loop over each (key, value) pair in `ds`. Returns nil." [x ds & body] (each-template x ds :pairs body)) (defmacro repeat "Evaluate body n times. If n is negative, body will be evaluated 0 times. Evaluates to nil." [n & body] (with-syms [iter] ~(do (var ,iter ,n) (while (> ,iter 0) ,;body (-- ,iter))))) (defmacro forever "Evaluate body forever in a loop, or until a break statement." [& body] ~(while true ,;body)) (defmacro each "Loop over each value in `ds`. Returns nil." [x ds & body] (each-template x ds :each body)) (defn- check-empty-body [body] (if (= (length body) 0) (maclintf :normal "empty loop body"))) (defmacro loop ``` A general purpose loop macro. This macro is similar to the Common Lisp loop macro, although intentionally much smaller in scope. The head of the loop should be a tuple that contains a sequence of either bindings or conditionals. A binding is a sequence of three values that define something to loop over. Bindings are written in the format: binding :verb object/expression where `binding` is a binding as passed to def, `:verb` is one of a set of keywords, and `object` is any expression. Each subsequent binding creates a nested loop within the loop created by the previous binding. The available verbs are: * `:iterate` -- repeatedly evaluate and bind to the expression while it is truthy. * `:range` -- loop over a range. The object should be a two-element tuple with a start and end value, and an optional positive step. The range is half open, [start, end). * `:range-to` -- same as :range, but the range is inclusive [start, end]. * `:down` -- loop over a range, stepping downwards. The object should be a two-element tuple with a start and (exclusive) end value, and an optional (positive!) step size. * `:down-to` -- same as :down, but the range is inclusive [start, end]. * `:keys` -- iterate over the keys in a data structure. * `:pairs` -- iterate over the key-value pairs as tuples in a data structure. * `:in` -- iterate over the values in a data structure or fiber. `loop` also accepts conditionals to refine the looping further. Conditionals are of the form: :modifier argument where `:modifier` is one of a set of keywords, and `argument` is keyword-dependent. `:modifier` can be one of: * `:while expression` -- breaks from the current loop if `expression` is falsey. * `:until expression` -- breaks from the current loop if `expression` is truthy. * `:let bindings` -- defines bindings inside the current loop as passed to the `let` macro. * `:before form` -- evaluates a form for a side effect before the next inner loop. * `:after form` -- same as `:before`, but the side effect happens after the next inner loop. * `:repeat n` -- repeats the next inner loop `n` times. * `:when condition` -- only evaluates the current loop body when `condition` is truthy. * `:unless condition` -- only evaluates the current loop body when `condition` is falsey. The `loop` macro always evaluates to nil. ``` [head & body] (loop1 body head 0)) (defmacro seq ``Similar to `loop`, but accumulates the loop body into an array and returns that. See `loop` for details.`` [head & body] (def $accum (gensym)) (check-empty-body body) ~(do (def ,$accum @[]) (loop ,head (,array/push ,$accum (do ,;body))) ,$accum)) (defmacro catseq ``Similar to `loop`, but concatenates each element from the loop body into an array and returns that. See `loop` for details.`` [head & body] (def $accum (gensym)) (check-empty-body body) ~(do (def ,$accum @[]) (loop ,head (,array/concat ,$accum (do ,;body))) ,$accum)) (defmacro tabseq ``Similar to `loop`, but accumulates key value pairs into a table. See `loop` for details.`` [head key-body & value-body] (def $accum (gensym)) ~(do (def ,$accum @{}) (loop ,head (,put ,$accum ,key-body (do ,;value-body))) ,$accum)) (defmacro generate ``Create a generator expression using the `loop` syntax. Returns a fiber that yields all values inside the loop in order. See `loop` for details.`` [head & body] (check-empty-body body) ~(,fiber/new (fn :generate [] (loop ,head (yield (do ,;body)))) :yi)) (defmacro coro "A wrapper for making fibers that may yield multiple values (coroutine). Same as `(fiber/new (fn [] ;body) :yi)`." [& body] (tuple fiber/new (tuple 'fn :coro '[] ;body) :yi)) (defmacro fiber-fn "A wrapper for making fibers. Same as `(fiber/new (fn [] ;body) flags)`." [flags & body] (tuple fiber/new (tuple 'fn :fiber-fn '[] ;body) flags)) (defn sum "Returns the sum of xs. If xs is empty, returns 0." [xs] (var accum 0) (each x xs (+= accum x)) accum) (defn mean "Returns the mean of xs. If empty, returns NaN." [xs] (if (lengthable? xs) (/ (sum xs) (length xs)) (do (var [accum total] [0 0]) (each x xs (+= accum x) (++ total)) (/ accum total)))) (defn geomean "Returns the geometric mean of xs. If empty, returns NaN." [xs] (if (lengthable? xs) (do (var accum 0) (each x xs (+= accum (math/log x))) (math/exp (/ accum (length xs)))) (do (var [accum total] [0 0]) (each x xs (+= accum (math/log x)) (++ total)) (math/exp (/ accum total))))) (defn product "Returns the product of xs. If xs is empty, returns 1." [xs] (var accum 1) (each x xs (*= accum x)) accum) # declare ahead of time (var- macexvar nil) (defmacro if-let ``Make multiple bindings, and if all are truthy, evaluate the `tru` form. If any are false or nil, evaluate the `fal` form. Bindings have the same syntax as the `let` macro.`` [bindings tru &opt fal] (def len (length bindings)) (if (= 0 len) (error "expected at least 1 binding")) (if (odd? len) (error "expected an even number of bindings")) (def fal2 (if macexvar (macexvar fal) fal)) (defn aux [i] (if (>= i len) tru (do (def bl (in bindings i)) (def br (in bindings (+ 1 i))) (if (symbol? bl) ~(if (def ,bl ,br) ,(aux (+ 2 i)) ,fal2) ~(if (def ,(def sym (gensym)) ,br) (do (def ,bl ,sym) ,(aux (+ 2 i))) ,fal2))))) (aux 0)) (defmacro when-let "Same as `(if-let bindings (do ;body))`." [bindings & body] ~(if-let ,bindings (do ,;body))) (defn comp `Takes multiple functions and returns a function that is the composition of those functions.` [& functions] (case (length functions) 0 nil 1 (in functions 0) 2 (let [[f g] functions] (fn :comp [& x] (f (g ;x)))) 3 (let [[f g h] functions] (fn :comp [& x] (f (g (h ;x))))) 4 (let [[f g h i] functions] (fn :comp [& x] (f (g (h (i ;x)))))) (let [[f g h i] functions] (comp (fn :comp [x] (f (g (h (i x))))) ;(tuple/slice functions 4 -1))))) (defn identity "A function that returns its argument." [x] x) (defn complement "Returns a function that is the complement to the argument." [f] (fn :complement [x] (not (f x)))) (defmacro- do-extreme [order args] ~(do (def ds ,args) (var k (next ds nil)) (var ret (get ds k)) (while (,not= nil (set k (next ds k))) (def x (in ds k)) (if (,order x ret) (set ret x))) ret)) (defn extreme ``Returns the most extreme value in `args` based on the function `order`. `order` should take two values and return true or false (a comparison). Returns nil if `args` is empty.`` [order args] (do-extreme order args)) (defn max "Returns the numeric maximum of the arguments." [& args] (do-extreme > args)) (defn min "Returns the numeric minimum of the arguments." [& args] (do-extreme < args)) (defn max-of "Returns the numeric maximum of the argument sequence." [args] (do-extreme > args)) (defn min-of "Returns the numeric minimum of the argument sequence." [args] (do-extreme < args)) (defn first "Get the first element from an indexed data structure." [xs] (get xs 0)) (defn last "Get the last element from an indexed data structure." [xs] (get xs (- (length xs) 1))) ## Polymorphic comparisons (defmacro- do-compare [x y] (def f (gensym)) (def f-res (gensym)) (def g (gensym)) (def g-res (gensym)) ~(do (def ,f (,get ,x :compare)) (def ,f-res (if ,f (,f ,x ,y))) (if ,f-res ,f-res (do (def ,g (,get ,y :compare)) (def ,g-res (if ,g (,- (,g ,y ,x)))) (if ,g-res ,g-res (,cmp ,x ,y)))))) (defn compare ``Polymorphic compare. Returns -1, 0, 1 for x < y, x = y, x > y respectively. Differs from the primitive comparators in that it first checks to see whether either x or y implement a `compare` method which can compare x and y. If so, it uses that method. If not, it delegates to the primitive comparators.`` [x y] (do-compare x y)) (defmacro- compare-reduce [op xs] ~(do (var res true) (var x (get ,xs 0)) (forv i 1 (length ,xs) (let [y (in ,xs i)] (if (,op (do-compare x y) 0) (set x y) (do (set res false) (break))))) res)) (defn compare= ``Equivalent of `=` but using polymorphic `compare` instead of primitive comparator.`` [& xs] (compare-reduce = xs)) (defn compare< ``Equivalent of `<` but using polymorphic `compare` instead of primitive comparator.`` [& xs] (compare-reduce < xs)) (defn compare<= ``Equivalent of `<=` but using polymorphic `compare` instead of primitive comparator.`` [& xs] (compare-reduce <= xs)) (defn compare> ``Equivalent of `>` but using polymorphic `compare` instead of primitive comparator.`` [& xs] (compare-reduce > xs)) (defn compare>= ``Equivalent of `>=` but using polymorphic `compare` instead of primitive comparator.`` [& xs] (compare-reduce >= xs)) (defn zero? "Check if x is zero." [x] (= (compare x 0) 0)) (defn pos? "Check if x is greater than 0." [x] (= (compare x 0) 1)) (defn neg? "Check if x is less than 0." [x] (= (compare x 0) -1)) (defn one? "Check if x is equal to 1." [x] (= (compare x 1) 0)) (defn even? "Check if x is even." [x] (= 0 (compare 0 (mod x 2)))) (defn odd? "Check if x is odd." [x] (= 0 (compare 1 (mod x 2)))) ### ### ### Indexed Combinators ### ### (defmacro- median-of-three [x y z] ~(if (<= ,x ,y) (if (<= ,y ,z) ,y (if (<= ,z ,x) ,x ,z)) (if (<= ,z ,y) ,y (if (<= ,x ,z) ,x ,z)))) (defmacro- sort-partition-template [ind before? left right pivot] ~(do (while (,before? (in ,ind ,left) ,pivot) (++ ,left)) (while (,before? ,pivot (in ,ind ,right)) (-- ,right)))) (defn- sort-help [a lo hi before?] (when (< lo hi) (def [x y z] [(in a lo) (in a (div (+ lo hi) 2)) (in a hi)]) (def pivot (median-of-three x y z)) (var left lo) (var right hi) (while true (case before? < (sort-partition-template a < left right pivot) > (sort-partition-template a > left right pivot) (sort-partition-template a before? left right pivot)) (when (<= left right) (def tmp (in a left)) (set (a left) (in a right)) (set (a right) tmp) (++ left) (-- right)) (if (>= left right) (break))) (if (< lo right) (sort-help a lo right before?)) (if (< left hi) (sort-help a left hi before?))) a) (defn sort ``Sorts `ind` in-place, and returns it. Uses quick-sort and is not a stable sort. If a `before?` comparator function is provided, sorts elements using that, otherwise uses `<`.`` [ind &opt before?] (default before? <) (sort-help ind 0 (- (length ind) 1) before?)) (defn sort-by ``Sorts `ind` in-place by calling a function `f` on each element and comparing the result with `<`.`` [f ind] (sort ind (fn :sort-by-comp [x y] (< (f x) (f y))))) (defn sorted ``Returns a new sorted array without modifying the old one. If a `before?` comparator function is provided, sorts elements using that, otherwise uses `<`.`` [ind &opt before?] (sort (array/slice ind) before?)) (defn sorted-by ``Returns a new sorted array that compares elements by invoking a function `f` on each element and comparing the result with `<`.`` [f ind] (sorted ind (fn :sorted-by-comp [x y] (< (f x) (f y))))) (defn reduce ``Reduce, also know as fold-left in many languages, transforms an indexed type (array, tuple) with a function to produce a value by applying `f` to each element in order. `f` is a function of 2 arguments, `(f accum el)`, where `accum` is the initial value and `el` is the next value in the indexed type `ind`. `f` returns a value that will be used as `accum` in the next call to `f`. `reduce` returns the value of the final call to `f`.`` [f init ind] (var accum init) (each el ind (set accum (f accum el))) accum) (defn reduce2 ``The 2-argument version of `reduce` that does not take an initialization value. Instead, the first element of the array is used for initialization. If `ind` is empty, will evaluate to nil.`` [f ind] (var k (next ind)) (if (= nil k) (break nil)) (var res (in ind k)) (set k (next ind k)) (while (not= nil k) (set res (f res (in ind k))) (set k (next ind k))) res) (defn accumulate ``Similar to `reduce`, but accumulates intermediate values into an array. The last element in the array is what would be the return value from `reduce`. The `init` value is not added to the array (the return value will have the same number of elements as `ind`). Returns a new array.`` [f init ind] (var res init) (def ret @[]) (each x ind (array/push ret (set res (f res x)))) ret) (defn accumulate2 ``The 2-argument version of `accumulate` that does not take an initialization value. The first value in `ind` will be added to the array as is, so the length of the return value will be `(length ind)`.`` [f ind] (var k (next ind)) (def ret @[]) (if (= nil k) (break ret)) (var res (in ind k)) (array/push ret res) (set k (next ind k)) (while (not= nil k) (set res (f res (in ind k))) (array/push ret res) (set k (next ind k))) ret) (defmacro- map-aggregator `Aggregation logic for various map functions.` [maptype res val] (case maptype :map ~(array/push ,res ,val) :mapcat ~(array/concat ,res ,val) :keep ~(if (def y ,val) (array/push ,res y)) :count ~(if ,val (++ ,res)) :some ~(if (def y ,val) (do (set ,res y) (break))) :all ~(if (def y ,val) nil (do (set ,res y) (break))))) (defmacro- map-n `Generates efficient map logic for a specific number of indexed beyond the first.` [n maptype res f ind inds] ~(do (def ,(seq [k :range [0 n]] (symbol 'ind k)) ,inds) ,;(seq [k :range [0 n]] ~(var ,(symbol 'key k) nil)) (each x ,ind ,;(seq [k :range [0 n]] ~(if (= nil (set ,(symbol 'key k) (next ,(symbol 'ind k) ,(symbol 'key k)))) (break))) (map-aggregator ,maptype ,res (,f x ,;(seq [k :range [0 n]] ~(in ,(symbol 'ind k) ,(symbol 'key k)))))))) (defmacro- map-template [maptype res f ind inds] ~(do (def ninds (length ,inds)) (case ninds 0 (each x ,ind (map-aggregator ,maptype ,res (,f x))) 1 (map-n 1 ,maptype ,res ,f ,ind ,inds) 2 (map-n 2 ,maptype ,res ,f ,ind ,inds) 3 (map-n 3 ,maptype ,res ,f ,ind ,inds) (do (def iter-keys (array/new-filled ninds)) (def call-buffer (array/new-filled ninds)) (var done false) (each x ,ind (forv i 0 ninds (let [old-key (in iter-keys i) ii (in ,inds i) new-key (next ii old-key)] (if (= nil new-key) (do (set done true) (break)) (do (set (iter-keys i) new-key) (set (call-buffer i) (in ii new-key)))))) (if done (break)) (map-aggregator ,maptype ,res (,f x ;call-buffer))))))) (defn map ``` Map a function `f` over every value in a data structure `ind` and return an array of results, but only if no `inds` are provided. Multiple data structures can be handled if each `inds` is a data structure and `f` is a function of arity one more than the number of `inds`. The resulting array has a length that is the shortest of `ind` and each of `inds`. ``` [f ind & inds] (def res @[]) (map-template :map res f ind inds) res) (defn mapcat ``` Map a function `f` over every value in a data structure `ind` and use `array/concat` to concatenate the results, but only if no `inds` are provided. Multiple data structures can be handled if each `inds` is a data structure and `f` is a function of arity one more than the number of `inds`. Note that `f` is only applied to values at indeces up to the largest index of the shortest of `ind` and each of `inds`. ``` [f ind & inds] (def res @[]) (map-template :mapcat res f ind inds) res) (defn filter ``Given a predicate, take only elements from an array or tuple for which `(pred element)` is truthy. Returns a new array.`` [pred ind] (def res @[]) (each item ind (if (pred item) (array/push res item))) res) (defn count ``` Count the number of values in a data structure `ind` for which applying `pred` yields a truthy value, but only if no `inds` are provided. Multiple data structures can be handled if each `inds` is a data structure and `pred` is a function of arity one more than the number of `inds`. Note that `pred` is only applied to values at indeces up to the largest index of the shortest of `ind` and each of `inds`. ``` [pred ind & inds] (var res 0) (map-template :count res pred ind inds) res) (defn keep ``` Given a predicate `pred`, return a new array containing the truthy results of applying `pred` to each value in the data structure `ind`, but only if no `inds` are provided. Multiple data structures can be handled if each `inds` is a data structure and `pred` is a function of arity one more than the number of `inds`. The resulting array has a length that is no longer than the shortest of `ind` and each of `inds`. ``` [pred ind & inds] (def res @[]) (map-template :keep res pred ind inds) res) (defn find-index ``Find the index of indexed type for which `pred` is true. Returns `dflt` if not found.`` [pred ind &opt dflt] (var k nil) (var ret dflt) (while true (set k (next ind k)) (if (= k nil) (break)) (def item (in ind k)) (when (pred item) (set ret k) (break))) ret) (defn find ``Find the first value in an indexed collection that satisfies a predicate. Returns `dflt` if not found.`` [pred ind &opt dflt] (var k nil) (var ret dflt) (while true (set k (next ind k)) (if (= k nil) (break)) (def item (in ind k)) (when (pred item) (set ret item) (break))) ret) (defn index-of ``Find the first key associated with a value x in a data structure, acting like a reverse lookup. Will not look at table prototypes. Returns `dflt` if not found.`` [x ind &opt dflt] (var k (next ind nil)) (var ret dflt) (while (not= nil k) (when (= (in ind k) x) (set ret k) (break)) (set k (next ind k))) ret) (defn- take-n-slice [f n ind] (def len (length ind)) (def m (+ len n)) (def start (if (< n 0 m) m 0)) (def end (if (<= 0 n len) n len)) (f ind start end)) (defn take ``Take the first n elements of a fiber, indexed or bytes type. Returns a new array, tuple or string, respectively. If `n` is negative, takes the last `n` elements instead.`` [n ind] (cond (indexed? ind) (take-n-slice tuple/slice n ind) (bytes? ind) (take-n-slice string/slice n ind) (dictionary? ind) (do (var left n) (tabseq [[i x] :pairs ind :until (< (-- left) 0)] i x)) (do (def res @[]) (var key nil) (repeat n (if (= nil (set key (next ind key))) (break)) (array/push res (in ind key))) res))) (defn- take-until-slice [f pred ind] (def len (length ind)) (def i (find-index pred ind)) (def end (if (nil? i) len i)) (f ind 0 end)) (defn take-until "Same as `(take-while (complement pred) ind)`." [pred ind] (cond (indexed? ind) (take-until-slice tuple/slice pred ind) (bytes? ind) (take-until-slice string/slice pred ind) (dictionary? ind) (tabseq [[i x] :pairs ind :until (pred x)] i x) (seq [x :in ind :until (pred x)] x))) (defn take-while `Given a predicate, take only elements from a fiber, indexed, or bytes type that satisfy the predicate, and abort on first failure. Returns a new array, tuple, or string, respectively.` [pred ind] (take-until (complement pred) ind)) (defn- drop-n-slice [f n ind] (def len (length ind)) (cond (<= 0 n len) (f ind n) (< (- len) n 0) (f ind 0 (+ len n)) (f ind len))) (defn- drop-n-dict [f n ind] (def res (f ind)) (var left n) (loop [[i x] :pairs ind :until (< (-- left) 0)] (set (res i) nil)) res) (defn drop ``Drop the first `n` elements in an indexed or bytes type. Returns a new tuple or string instance, respectively. If `n` is negative, drops the last `n` elements instead.`` [n ind] (cond (indexed? ind) (drop-n-slice tuple/slice n ind) (bytes? ind) (drop-n-slice string/slice n ind) (struct? ind) (drop-n-dict struct/to-table n ind) (table? ind) (drop-n-dict table/clone n ind) (do (var key nil) (repeat n (if (= nil (set key (next ind key))) (break))) ind))) (defn- drop-until-slice [f pred ind] (def len (length ind)) (def i (find-index pred ind)) (def start (if (nil? i) len i)) (f ind start)) (defn- drop-until-dict [f pred ind] (def res (f ind)) (loop [[i x] :pairs ind :until (pred x)] (set (res i) nil)) res) (defn drop-until "Same as `(drop-while (complement pred) ind)`." [pred ind] (cond (indexed? ind) (drop-until-slice tuple/slice pred ind) (bytes? ind) (drop-until-slice string/slice pred ind) (struct? ind) (drop-until-dict struct/to-table pred ind) (table? ind) (drop-until-dict table/clone pred ind) (do (find pred ind) ind))) (defn drop-while `Given a predicate, remove elements from an indexed or bytes type that satisfy the predicate, and abort on first failure. Returns a new tuple or string, respectively.` [pred ind] (drop-until (complement pred) ind)) (defn juxt* ``Returns the juxtaposition of functions. In other words, `((juxt* a b c) x)` evaluates to `[(a x) (b x) (c x)]`.`` [& funs] (fn :juxt* [& args] (def ret @[]) (each f funs (array/push ret (f ;args))) (tuple/slice ret 0))) (defmacro juxt "Macro form of `juxt*`. Same behavior but more efficient." [& funs] (def parts @['tuple]) (def $args (gensym)) (each f funs (array/push parts (tuple apply f $args))) (tuple 'fn :juxt (tuple '& $args) (tuple/slice parts 0))) (defn has-key? "Check if a data structure `ds` contains the key `key`." [ds key] (not= nil (get ds key))) (defn has-value? "Check if a data structure `ds` contains the value `value`. Will run in time proportional to the size of `ds`." [ds value] (not= nil (index-of value ds))) (defdyn *defdyn-prefix* ``Optional namespace prefix to add to keywords declared with `defdyn`. Use this to prevent keyword collisions between dynamic bindings.``) (defdyn *out* "Where normal print functions print output to.") (defdyn *err* "Where error printing prints output to.") (defdyn *redef* "When set, allow dynamically rebinding top level defs. Will slow generated code and is intended to be used for development.") (defdyn *debug* "Enables a built in debugger on errors and other useful features for debugging in a repl.") (defdyn *exit* "When set, will cause the current context to complete. Can be set to exit from repl (or file), for example.") (defdyn *exit-value* "Set the return value from `run-context` upon an exit.") (defdyn *task-id* "When spawning a thread or fiber, the task-id can be assigned for concurrency control.") (defdyn *current-file* "Bound to the name of the currently compiling file.") (defmacro tracev `Print to stderr a value and a description of the form that produced that value. Evaluates to x.` [x] (def [l c] (tuple/sourcemap (dyn *macro-form* ()))) (def cf (dyn *current-file*)) (def fmt-1 (if cf (string/format "trace [%s]" cf) "trace")) (def fmt-2 (if (or (neg? l) (neg? c)) ":" (string/format " on line %d, column %d:" l c))) (def fmt (string fmt-1 fmt-2 " %j is ")) (def s (gensym)) ~(upscope (def ,s ,x) (,eprinf ,fmt ',x) (,eprintf (,dyn :pretty-format "%q") ,s) ,s)) (defn keep-syntax ``Creates a tuple with the tuple type and sourcemap of `before` but the elements of `after`. If either one of its arguments is not a tuple, returns `after` unmodified. Useful to preserve syntactic information when transforming an ast in macros.`` [before after] (if (and (= :tuple (type before)) (= :tuple (type after))) (do (def res (if (= :parens (tuple/type before)) (tuple/slice after) (tuple/brackets ;after))) (tuple/setmap res ;(tuple/sourcemap before))) after)) (defn keep-syntax! ``Like `keep-syntax`, but if `after` is an array, it is coerced into a tuple. Useful to preserve syntactic information when transforming an ast in macros.`` [before after] (keep-syntax before (if (= :array (type after)) (tuple/slice after) after))) (defmacro -> ``Threading macro. Inserts x as the second value in the first form in `forms`, and inserts the modified first form into the second form in the same manner, and so on. Useful for expressing pipelines of data.`` [x & forms] (defn fop [last n] (def [h t] (if (= :tuple (type n)) (tuple (in n 0) (array/slice n 1)) (tuple n @[]))) (def parts (array/concat @[h last] t)) (keep-syntax! n parts)) (reduce fop x forms)) (defmacro ->> ``Threading macro. Inserts x as the last value in the first form in `forms`, and inserts the modified first form into the second form in the same manner, and so on. Useful for expressing pipelines of data.`` [x & forms] (defn fop [last n] (def [h t] (if (= :tuple (type n)) (tuple (in n 0) (array/slice n 1)) (tuple n @[]))) (def parts (array/concat @[h] t @[last])) (keep-syntax! n parts)) (reduce fop x forms)) (defmacro -?> ``Short circuit threading macro. Inserts x as the second value in the first form in `forms`, and inserts the modified first form into the second form in the same manner, and so on. The pipeline will return nil if an intermediate value is nil. Useful for expressing pipelines of data.`` [x & forms] (defn fop [last n] (def [h t] (if (= :tuple (type n)) (tuple (in n 0) (array/slice n 1)) (tuple n @[]))) (def sym (gensym)) (def parts (array/concat @[h sym] t)) ~(let [,sym ,last] (if ,sym ,(keep-syntax! n parts)))) (reduce fop x forms)) (defmacro -?>> ``Short circuit threading macro. Inserts x as the last value in the first form in `forms`, and inserts the modified first form into the second form in the same manner, and so on. The pipeline will return nil if an intermediate value is nil. Useful for expressing pipelines of data.`` [x & forms] (defn fop [last n] (def [h t] (if (= :tuple (type n)) (tuple (in n 0) (array/slice n 1)) (tuple n @[]))) (def sym (gensym)) (def parts (array/concat @[h] t @[sym])) ~(let [,sym ,last] (if ,sym ,(keep-syntax! n parts)))) (reduce fop x forms)) (defn- walk-ind [f form] (def ret @[]) (each x form (array/push ret (f x))) ret) (defn- walk-dict [f form] (def ret @{}) (loop [k :keys form] (put ret (f k) (f (in form k)))) ret) (defn- walk-dict-values [f form] (def ret @{}) (loop [k :keys form] (put ret k (f (in form k)))) ret) (defn walk ``Iterate over the values in ast and apply `f` to them. Collect the results in a data structure. If ast is not a table, struct, array, or tuple, returns form.`` [f form] (case (type form) :table (walk-dict f form) :struct (table/to-struct (walk-dict f form)) :array (walk-ind f form) :tuple (keep-syntax! form (walk-ind f form)) form)) (defn postwalk ``Do a post-order traversal of a data structure and call `(f x)` on every visitation.`` [f form] (f (walk (fn [x] (postwalk f x)) form))) (defn prewalk "Similar to `postwalk`, but do pre-order traversal." [f form] (walk (fn [x] (prewalk f x)) (f form))) (defmacro as-> ``Thread forms together, replacing `as` in `forms` with the value of the previous form. The first form is the value x. Returns the last value.`` [x as & forms] (var prev x) (each form forms (def sym (gensym)) (def next-prev (postwalk (fn [y] (if (= y as) sym y)) form)) (set prev ~(let [,sym ,prev] ,next-prev))) prev) (defmacro as?-> ``Thread forms together, replacing `as` in `forms` with the value of the previous form. The first form is the value x. If any intermediate values are falsey, return nil; otherwise, returns the last value.`` [x as & forms] (var prev x) (each form forms (def sym (gensym)) (def next-prev (postwalk (fn [y] (if (= y as) sym y)) form)) (set prev ~(if-let [,sym ,prev] ,next-prev))) prev) (defmacro with-dyns `Run a block of code in a new fiber that has some dynamic bindings set. The fiber will not mask errors or signals, but the dynamic bindings will be properly unset, as dynamic bindings are fiber-local.` [bindings & body] (def dyn-forms (seq [i :range [0 (length bindings) 2]] ~(setdyn ,(bindings i) ,(bindings (+ i 1))))) ~(,resume (,fiber/new (fn :with-dyns [] ,;dyn-forms ,;body) :p))) (defmacro with-env `Run a block of code with a given environment table` [env & body] ~(,resume (,fiber/new (fn :with-env [] ,;body) : ,env))) (defmacro with-vars ``Evaluates `body` with each var in `vars` temporarily bound. Similar signature to `let`, but each binding must be a var.`` [vars & body] (def len (length vars)) (unless (even? len) (error "expected even number of argument to vars")) (def temp (seq [i :range [0 len 2]] (gensym))) (def saveold (seq [i :range [0 len 2]] ['def (temp (/ i 2)) (vars i)])) (def setnew (seq [i :range [0 len 2]] ['set (vars i) (vars (+ i 1))])) (def restoreold (seq [i :range [0 len 2]] ['set (vars i) (temp (/ i 2))])) (with-syms [ret f s] ~(do ,;saveold (def ,f (,fiber/new (fn :with-vars [] ,;setnew ,;body) :ti)) (def ,ret (,resume ,f)) ,;restoreold (if (= (,fiber/status ,f) :dead) ,ret (,propagate ,ret ,f))))) (defn partial "Partial function application." [f & more] (if (zero? (length more)) f (fn :partial [& r] (f ;more ;r)))) (defn every? ``Evaluates to the last element of `ind` if all preceding elements are truthy, otherwise evaluates to the first falsey element.`` [ind] (var res true) (loop [x :in ind :while res] (set res x)) res) (defn any? ``Evaluates to the last element of `ind` if all preceding elements are falsey, otherwise evaluates to the first truthy element.`` [ind] (var res nil) (loop [x :in ind :until res] (set res x)) res) (defn reverse! `Reverses the order of the elements in a given array or buffer and returns it mutated.` [t] (var i 0) (var j (length t)) (while (< i (-- j)) (def ti (in t i)) (put t i (in t j)) (put t j ti) (++ i)) t) (defn reverse `Reverses the order of the elements in a given array or tuple and returns a new array. If a string or buffer is provided, returns a buffer instead.` [t] (if (lengthable? t) (do (var n (length t)) (def ret (if (bytes? t) (buffer/new-filled n) (array/new-filled n))) (each v t (put ret (-- n) v)) ret) (reverse! (seq [v :in t] v)))) (defn invert ``Given an associative data structure `ds`, returns a new table where the keys of `ds` are the values, and the values are the keys. If multiple keys in `ds` are mapped to the same value, only one of those values will become a key in the returned table.`` [ds] (def ret @{}) (loop [k :keys ds] (put ret (in ds k) k)) ret) (defn zipcoll `Creates a table from two arrays/tuples. Returns a new table.` [ks vs] (def res @{}) (var kk nil) (var vk nil) (while true (set kk (next ks kk)) (if (= nil kk) (break)) (set vk (next vs vk)) (if (= nil vk) (break)) (put res (in ks kk) (in vs vk))) res) (defn get-in ``Access a value in a nested data structure. Looks into the data structure via a sequence of keys. If value is not found, and `dflt` is provided, returns `dflt`.`` [ds ks &opt dflt] (var d ds) (loop [k :in ks :while (not (nil? d))] (set d (get d k))) (if (= nil d) dflt d)) (defn update-in ``Update a value in a nested data structure `ds`. Looks into `ds` via a sequence of keys, and replaces the value found there with `f` applied to that value. Missing data structures will be replaced with tables. Returns the modified, original data structure.`` [ds ks f & args] (var d ds) (def len-1 (- (length ks) 1)) (if (< len-1 0) (error "expected at least 1 key in ks")) (forv i 0 len-1 (def k (get ks i)) (def v (get d k)) (if (= nil v) (let [newv (table)] (put d k newv) (set d newv)) (set d v))) (def last-key (get ks len-1)) (def last-val (get d last-key)) (put d last-key (f last-val ;args)) ds) (defn put-in ``Put a value into a nested data structure `ds`. Looks into `ds` via a sequence of keys. Missing data structures will be replaced with tables. Returns the modified, original data structure.`` [ds ks v] (var d ds) (def len-1 (- (length ks) 1)) (if (< len-1 0) (error "expected at least 1 key in ks")) (forv i 0 len-1 (def k (get ks i)) (def v (get d k)) (if (= nil v) (let [newv (table)] (put d k newv) (set d newv)) (set d v))) (def last-key (get ks len-1)) (def last-val (get d last-key)) (put d last-key v) ds) (defn update ``For a given key in data structure `ds`, replace its corresponding value with the result of calling `func` on that value. If `args` are provided, they will be passed along to `func` as well. Returns `ds`, updated.`` [ds key func & args] (def old (get ds key)) (put ds key (func old ;args))) (defn merge-into ``Merges multiple tables/structs into table `tab`. If a key appears in more than one collection in `colls`, then later values replace any previous ones. Returns `tab`.`` [tab & colls] (loop [c :in colls key :keys c] (put tab key (in c key))) tab) (defn merge ``Merges multiple tables/structs into one new table. If a key appears in more than one collection in `colls`, then later values replace any previous ones. Returns the new table.`` [& colls] (def container @{}) (loop [c :in colls key :keys c] (put container key (in c key))) container) (defn keys "Get the keys of an associative data structure." [x] (if (lengthable? x) (do (def arr (array/new-filled (length x))) (var i 0) (eachk k x (put arr i k) (++ i)) arr) (seq [k :keys x] k))) (defn values "Get the values of an associative data structure." [x] (if (lengthable? x) (do (def arr (array/new-filled (length x))) (var i 0) (each v x (put arr i v) (++ i)) arr) (seq [v :in x] v))) (defn pairs "Get the key-value pairs of an associative data structure." [x] (if (lengthable? x) (do (def arr (array/new-filled (length x))) (var i 0) (eachp p x (put arr i p) (++ i)) arr) (seq [p :pairs x] p))) (defn frequencies "Get the number of occurrences of each value in an indexed data structure." [ind] (def freqs @{}) (each x ind (def n (in freqs x)) (set (freqs x) (if n (+ 1 n) 1))) freqs) (defn group-by ``Group elements of `ind` by a function `f` and put the results into a new table. The keys of the table are the distinct return values from calling `f` on the elements of `ind`. The values of the table are arrays of all elements of `ind` for which `f` called on the element equals that corresponding key.`` [f ind] (def ret @{}) (each x ind (def y (f x)) (if-let [arr (get ret y)] (array/push arr x) (put ret y @[x]))) ret) (defn partition-by ``Partition elements of a sequential data structure by a representative function `f`. Partitions split when `(f x)` changes values when iterating to the next element `x` of `ind`. Returns a new array of arrays.`` [f ind] (def ret @[]) (var span nil) (var category nil) (var is-new true) (each x ind (def y (f x)) (cond is-new (do (set is-new false) (set category y) (set span @[x]) (array/push ret span)) (= y category) (array/push span x) (do (set category y) (set span @[x]) (array/push ret span)))) ret) (defn interleave "Returns an array of the first elements of each col, then the second elements, etc." [& cols] (mapcat tuple ;cols)) (defn distinct "Returns an array of the deduplicated values in `xs`." [xs] (def ret @[]) (def seen @{}) (each x xs (if (in seen x) nil (do (put seen x true) (array/push ret x)))) ret) (defn flatten-into ``Takes a nested array (tree) `xs` and appends the depth first traversal of `xs` to array `into`. Returns `into`.`` [into xs] (each x xs (if (indexed? x) (flatten-into into x) (array/push into x))) into) (defn flatten ``Takes a nested array (tree) `xs` and returns the depth first traversal of it. Returns a new array.`` [xs] (flatten-into @[] xs)) (defn kvs ``Takes a table or struct and returns a new array of key value pairs like `@[k v k v ...]`.`` [dict] (def ret @[]) (loop [k :keys dict] (array/push ret k (in dict k))) ret) (defn from-pairs ``Takes a sequence of pairs and creates a table from each pair. It is the inverse of `pairs` on a table. Returns a new table.`` [ps] (def ret @{}) (each [k v] ps (put ret k v)) ret) (defn interpose ``Returns a sequence of the elements of `ind` separated by `sep`. Returns a new array.`` [sep ind] (var k (next ind nil)) (if (not= nil k) (if (lengthable? ind) (do (def ret (array/new-filled (- (* 2 (length ind)) 1) sep)) (var i 0) (while (not= nil k) (put ret i (in ind k)) (set k (next ind k)) (+= i 2)) ret) (do (def ret @[(in ind k)]) (while (not= nil (set k (next ind k))) (array/push ret sep (in ind k))) ret)) @[])) (defn- partition-slice [f n ind] (var [start end] [0 n]) (def len (length ind)) (def parts (div len n)) (def ret (array/new-filled parts)) (forv k 0 parts (put ret k (f ind start end)) (set start end) (+= end n)) (if (< start len) (array/push ret (f ind start))) ret) (defn partition ``Partition an indexed data structure `ind` into tuples of size `n`. Returns a new array.`` [n ind] (cond (indexed? ind) (partition-slice tuple/slice n ind) (bytes? ind) (partition-slice string/slice n ind) (partition-slice tuple/slice n (values ind)))) ### ### ### IO Helpers ### ### (defn slurp ``Read all data from a file with name `path` and then close the file.`` [path] (def f (file/open path :rb)) (if-not f (error (string "could not open file " path))) (def contents (file/read f :all)) (file/close f) contents) (defn spit ``Write `contents` to a file at `path`. Can optionally append to the file.`` [path contents &opt mode] (default mode :wb) (def f (file/open path mode)) (if-not f (error (string "could not open file " path " with mode " mode))) (file/write f contents) (file/close f) nil) (defdyn *pretty-format* "Format specifier for the `pp` function") (defdyn *repl-prompt* "Allow setting a custom prompt at the default REPL. Not all REPLs will respect this binding.") (defn pp ``Pretty-print to stdout or `(dyn *out*)`. The format string used is `(dyn *pretty-format* "%q")`.`` [x] (printf (dyn *pretty-format* "%q") x) (flush)) (defn file/lines "Return an iterator over the lines of a file." [file] (coro (while (def line (file/read file :line)) (yield line)))) ### ### ### Pattern Matching ### ### (defmacro match ``` Pattern matching. Match an expression `x` against any number of cases. Each case is a pattern to match against, followed by an expression to evaluate to if that case is matched. Legal patterns are: * symbol -- a pattern that is a symbol will match anything, binding `x`'s value to that symbol. * array or bracket tuple -- an array or bracket tuple will match only if all of its elements match the corresponding elements in `x`. Use `& rest` at the end of an array or bracketed tuple to bind all remaining values to `rest`. * table or struct -- a table or struct will match if all values match with the corresponding values in `x`. * tuple -- a tuple pattern will match if its first element matches, and the following elements are treated as predicates and are true. * `_` symbol -- the last special case is the `_` symbol, which is a wildcard that will match any value without creating a binding. While a symbol pattern will ordinarily match any value, the pattern `(@ )`, where `` is any symbol, will attempt to match `x` against a value already bound to ``, rather than matching and rebinding it. Any other value pattern will only match if it is equal to `x`. Quoting a pattern with `'` will also treat the value as a literal value to match against. ``` [x & cases] # Partition body into sections. (def oddlen (odd? (length cases))) (def else (if oddlen (last cases))) (def patterns (partition 2 (if oddlen (slice cases 0 -2) cases))) # Keep an array for accumulating the compilation output (def x-sym (if (idempotent? x) x (gensym))) (def accum @[]) (if (not= x x-sym) (array/push accum ['def x-sym x])) # Table of gensyms (def symbols @{[nil nil] x-sym}) (def length-symbols @{}) (defn emit [x] (array/push accum x)) (defn emit-branch [condition result] (array/push accum :branch condition result)) (defn get-sym [parent-sym key] (def symbol-key [parent-sym key]) (or (get symbols symbol-key) (let [s (gensym)] (put symbols symbol-key s) (emit ['def s [get parent-sym key]]) s))) (defn get-length-sym [parent-sym] (or (get length-symbols parent-sym) (let [s (gensym)] (put length-symbols parent-sym s) (emit ['def s ['if [indexed? parent-sym] [length parent-sym]]]) s))) (defn visit-pattern-1 [b2g parent-sym key pattern] (if (= pattern '_) (break)) (def s (get-sym parent-sym key)) (def t (type pattern)) (def isarr (or (= t :array) (and (= t :tuple) (= (tuple/type pattern) :brackets)))) (cond # match local binding (= t :symbol) (if-let [x (in b2g pattern)] (array/push x s) (put b2g pattern @[s])) # match quoted literal (and (= t :tuple) (= 2 (length pattern)) (= 'quote (pattern 0))) (break) # match data structure template (or (= t :struct) (= t :table)) (eachp [i sub-pattern] pattern (visit-pattern-1 b2g s i sub-pattern)) isarr (do (get-length-sym s) (eachp [i sub-pattern] pattern (when (= sub-pattern '&) (when (<= (length pattern) (inc i)) (errorf "expected symbol following & in pattern")) (when (< (+ i 2) (length pattern)) (errorf "expected a single symbol follow '& in pattern, found %q" (slice pattern (inc i)))) (when (not= (type (pattern (inc i))) :symbol) (errorf "expected symbol following & in pattern, found %q" (pattern (inc i)))) (put b2g (pattern (inc i)) @[[slice s i]]) (break)) (when (= sub-pattern '$) (when (not= (length pattern) (inc i)) (error "expected $ to be last symbol in pattern")) (break)) (visit-pattern-1 b2g s i sub-pattern))) # match global unification (and (= t :tuple) (= 2 (length pattern)) (= '@ (pattern 0))) (break) # match predicated binding (and (= t :tuple) (>= (length pattern) 2)) (do (visit-pattern-1 b2g parent-sym key (pattern 0))))) (defn visit-pattern-2 [anda gun preds parent-sym key pattern] (if (= pattern '_) (break)) (def s (get-sym parent-sym key)) (def t (type pattern)) (def isarr (or (= t :array) (and (= t :tuple) (= (tuple/type pattern) :brackets)))) (when isarr (array/push anda (get-length-sym s)) (def amp-index (find-index (fn [x] (= x '&)) pattern)) (def dollar-index (find-index (fn [x] (= x '$)) pattern)) (def pattern-len (or dollar-index amp-index (length pattern))) (array/push anda [(if dollar-index = <=) pattern-len (get-length-sym s)])) (cond # match data structure template (or (= t :struct) (= t :table)) (eachp [i sub-pattern] pattern (array/push anda [not= nil (get-sym s i)]) (visit-pattern-2 anda gun preds s i sub-pattern)) isarr (eachp [i sub-pattern] pattern # stop recursing to sub-patterns if the rest sigil is found (when (or (= sub-pattern '$) (= sub-pattern '&)) (break)) (visit-pattern-2 anda gun preds s i sub-pattern)) # match local binding (= t :symbol) (break) # match quoted literal (and (= t :tuple) (= 2 (length pattern)) (= 'quote (pattern 0))) (array/push anda ['= s pattern]) # match global unification (and (= t :tuple) (= 2 (length pattern)) (= '@ (pattern 0))) (if-let [x (in gun (pattern 1))] (array/push x s) (put gun (pattern 1) @[s])) # match predicated binding (and (= t :tuple) (>= (length pattern) 2)) (do (array/push preds ;(slice pattern 1)) (visit-pattern-2 anda gun preds parent-sym key (pattern 0))) # match literal (array/push anda ['= s pattern]))) # Compile the patterns (each [pattern expression] patterns (def b2g @{}) (def gun @{}) (def preds @[]) (visit-pattern-1 b2g nil nil pattern) (def anda @['and]) (visit-pattern-2 anda gun preds nil nil pattern) # Local unification (def unify @[]) (each syms b2g (when (< 1 (length syms)) (array/push unify [= ;syms]))) # Global unification (eachp [binding syms] gun (array/push unify [= binding ;syms])) (sort unify) (array/concat anda unify) # Final binding (def defs (seq [[k v] :in (sort (pairs b2g))] ['def k (first v)])) (def unused-defs (seq [[k v] :in (sort (pairs b2g))] ['def k :unused (first v)])) # Predicates (unless (empty? preds) (def pred-join ~(do ,;unused-defs (and ,;preds))) (array/push anda pred-join)) # Use `unused-defs` instead of `defs` when we have predicates to avoid unused binding lint # e.g. (match x (n (even? n)) :yes :no) should not warn on unused binding `n`. # This is unfortunately not perfect since one programmer written binding is expanded for use in multiple places. (emit-branch (tuple/slice anda) ['do ;(if (next preds) unused-defs defs) expression])) # Expand branches (def stack @[else]) (each el (reverse accum) (if (= :branch el) (let [condition (array/pop stack) truthy (array/pop stack) if-form ~(if ,condition ,truthy ,(case (length stack) 0 nil 1 (stack 0) ~(do ,;(reverse stack))))] (array/remove stack 0 (length stack)) (array/push stack if-form)) (array/push stack el))) ~(do ,;(reverse stack))) ### ### ### Macro Expansion ### ### (defn macex1 ``Expand macros in a form, but do not recursively expand macros. See `macex` docs for info on `on-binding`.`` [x &opt on-binding] (when on-binding (when (symbol? x) (break (on-binding x)))) (defn recur [y] (macex1 y on-binding)) (defn dotable [t on-value] (def newt @{}) (var key (next t nil)) (while (not= nil key) (put newt (recur key) (on-value (in t key))) (set key (next t key))) newt) (defn expand-bindings [x] (case (type x) :array (map expand-bindings x) :tuple (keep-syntax! x (map expand-bindings x)) :table (dotable x expand-bindings) :struct (table/to-struct (dotable x expand-bindings)) (recur x))) (defn expanddef [t] (def last (in t (- (length t) 1))) (def bound (in t 1)) (keep-syntax! t (array/concat @[(in t 0) (expand-bindings bound)] (tuple/slice t 2 -2) @[(recur last)]))) (defn expandall [t] (def args (map recur (tuple/slice t 1))) (tuple (in t 0) ;args)) (defn expandfn [t] (def t1 (in t 1)) (if (symbol? t1) (do (def args (map recur (tuple/slice t 3))) (keep-syntax t (tuple 'fn t1 (in t 2) ;args))) (do (def args (map recur (tuple/slice t 2))) (keep-syntax t (tuple 'fn t1 ;args))))) (defn expandqq [t] (defn qq [x] (case (type x) :tuple (if (= :brackets (tuple/type x)) ~[,;(map qq x)] (do (def x0 (get x 0)) (if (= 'unquote x0) (tuple x0 (recur (get x 1))) (tuple/slice (map qq x))))) :array (map qq x) :table (table ;(map qq (kvs x))) :struct (struct ;(map qq (kvs x))) x)) (tuple (in t 0) (qq (in t 1)))) (def specs {'set expanddef 'def expanddef 'do expandall 'fn expandfn 'if expandall 'quote identity 'quasiquote expandqq 'var expanddef 'while expandall 'break expandall 'upscope expandall}) (defn dotup [t] (if (= nil (next t)) (break ())) (def h (in t 0)) (def s (in specs h)) (def entry (or (dyn h) {})) (def m (do (def r (get entry :ref)) (if r (in r 0) (get entry :value)))) (def m? (in entry :macro)) (cond s (keep-syntax t (s t)) m? (do (setdyn *macro-form* t) (m ;(tuple/slice t 1))) (keep-syntax! t (map recur t)))) (def ret (case (type x) :tuple (if (= (tuple/type x) :brackets) (tuple/brackets ;(map recur x)) (dotup x)) :array (map recur x) :struct (table/to-struct (dotable x recur)) :table (dotable x recur) x)) ret) (defn all ``` Returns true if applying `pred` to every value in a data structure `ind` results in only truthy values, but only if no `inds` are provided. Multiple data structures can be handled if each `inds` is a data structure and `pred` is a function of arity one more than the number of `inds`. Returns the first falsey result encountered. Note that `pred` is only called as many times as the length of the shortest of `ind` and each of `inds`. If `ind` or any of `inds` are empty, returns true. ``` [pred ind & inds] (var res true) (map-template :all res pred ind inds) res) (defn some ``` Returns nil if applying `pred` to every value in a data structure `ind` results in only falsey values, but only if no `inds` are provided. Multiple data structures can be handled if each `inds` is a data structure and `pred` is a function of arity one more than the number of `inds`. Returns the first truthy result encountered. Note that `pred` is only called as many times as the length of the shortest of `ind` and each of `inds`. If `ind` or any of `inds` are empty, returns nil. ``` [pred ind & inds] (var res nil) (map-template :some res pred ind inds) res) (defn freeze `Freeze an object (make it immutable) and do a deep copy, making child values also immutable. Closures, fibers, and abstract types will not be recursively frozen, but all other types will.` [x] (def tx (type x)) (cond (or (= tx :array) (= tx :tuple)) (tuple/slice (map freeze x)) (or (= tx :table) (= tx :struct)) (let [temp-tab @{}] # Handle multiple unique keys that freeze. Result should # be independent of iteration order. (eachp [k v] x (def kk (freeze k)) (def vv (freeze v)) (def old (get temp-tab kk)) (def new (if (= nil old) vv (max vv old))) (put temp-tab kk new)) (table/to-struct temp-tab (freeze (getproto x)))) (= tx :buffer) (string x) x)) (defn thaw ``` Thaw an object (make it mutable) and do a deep copy, making child values also mutable. Closures, fibers, and abstract types will not be recursively thawed, but all other types will. ``` [ds] (case (type ds) :array (walk-ind thaw ds) :tuple (walk-ind thaw ds) :table (walk-dict thaw (table/proto-flatten ds)) :struct (walk-dict thaw (struct/proto-flatten ds)) :string (buffer ds) ds)) (defn thaw-keep-keys ``` Similar to `thaw`, but do not modify table or struct keys. ``` [ds] (case (type ds) :array (walk-ind thaw-keep-keys ds) :tuple (walk-ind thaw-keep-keys ds) :table (walk-dict-values thaw-keep-keys (table/proto-flatten ds)) :struct (walk-dict-values thaw-keep-keys (struct/proto-flatten ds)) :string (buffer ds) ds)) (defn deep-not= ``Like `not=`, but mutable types (arrays, tables, buffers) are considered equal if they have identical structure. Much slower than `not=`.`` [x y] (def tx (type x)) (or (not= tx (type y)) (cond (or (= tx :tuple) (= tx :array)) (or (not= (length x) (length y)) (do (var ret false) (forv i 0 (length x) (def xx (in x i)) (def yy (in y i)) (if (deep-not= xx yy) (break (set ret true)))) ret)) (or (= tx :struct) (= tx :table)) (or (not= (length x) (length y)) (do (def rawget (if (= tx :struct) struct/rawget table/rawget)) (var ret false) (eachp [k v] x (if (deep-not= (rawget y k) v) (break (set ret true)))) ret)) (= tx :buffer) (not= 0 (- (length x) (length y)) (memcmp x y)) (not= x y)))) (defn deep= ``Like `=`, but mutable types (arrays, tables, buffers) are considered equal if they have identical structure. Much slower than `=`.`` [x y] (not (deep-not= x y))) (defn macex ``Expand macros completely. `on-binding` is an optional callback for whenever a normal symbolic binding is encountered. This allows macros to easily see all bindings used by their arguments by calling `macex` on their contents. The binding itself is also replaced by the value returned by `on-binding` within the expanded macro.`` [x &opt on-binding] (var previous x) (var current (macex1 x on-binding)) (var counter 0) (while (deep-not= current previous) (if (> (++ counter) 200) (error "macro expansion too nested")) (set previous current) (set current (macex1 current on-binding))) current) (set macexvar macex) (defmacro varfn :flycheck ``Create a function that can be rebound. `varfn` has the same signature as `defn`, but defines functions in the environment as vars. If a var `name` already exists in the environment, it is rebound to the new function. Returns a function.`` [name & body] (def expansion (apply defn name body)) (def fbody (last expansion)) (def modifiers (tuple/slice expansion 2 -2)) (def metadata @{}) (each m modifiers (cond (keyword? m) (put metadata m true) (string? m) (put metadata :doc m) (dictionary? m) (merge-into metadata m) (error (string "invalid metadata " m)))) (with-syms [entry old-entry f] ~(let [,old-entry (,dyn ',name)] (def ,entry (or ,old-entry @{:ref @[nil]})) (,setdyn ',name ,entry) (def ,f ,fbody) (,put-in ,entry [:ref 0] ,f) (,merge-into ,entry ',metadata) ,f))) ### ### ### Function shorthand ### ### (defmacro short-fn ``` Shorthand for `fn`. Arguments are given as `$n`, where `n` is the 0-indexed argument of the function. `$` is also an alias for the first (index 0) argument. The `$&` symbol will make the anonymous function variadic if it appears in the body of the function, and can be combined with positional arguments. ``` [arg &opt name] (var max-param-seen -1) (var vararg false) (defn saw-special-arg [num] (set max-param-seen (max max-param-seen num))) (def prefix (gensym)) (defn on-binding [x] (if (string/has-prefix? '$ x) (cond (= '$ x) (do (saw-special-arg 0) (symbol prefix '$0)) (= '$& x) (do (set vararg true) (symbol prefix x)) :else (do (def num (scan-number (string/slice x 1))) (if (nat? num) (do (saw-special-arg num) (symbol prefix x)) x))) x)) (def expanded (macex arg on-binding)) (def name-splice (if name [name] [:short-fn])) (def fn-args (seq [i :range [0 (+ 1 max-param-seen)]] (symbol prefix '$ i))) ~(fn ,;name-splice [,;fn-args ,;(if vararg ['& (symbol prefix '$&)] [])] ,expanded)) ### ### ### Default PEG patterns ### ### (defdyn *peg-grammar* ``The implicit base grammar used when compiling PEGs. Any undefined keywords found when compiling a peg will use lookup in this table (if defined).``) (def default-peg-grammar `The default grammar used for pegs. This grammar defines several common patterns that should make it easier to write more complex patterns.` ~@{:a (range "az" "AZ") :d (range "09") :h (range "09" "af" "AF") :s (set " \t\r\n\0\f\v") :w (range "az" "AZ" "09") :A (if-not :a 1) :D (if-not :d 1) :H (if-not :h 1) :S (if-not :s 1) :W (if-not :w 1) :a+ (some :a) :d+ (some :d) :h+ (some :h) :s+ (some :s) :w+ (some :w) :A+ (some :A) :D+ (some :D) :H+ (some :H) :S+ (some :S) :W+ (some :W) :a* (any :a) :d* (any :d) :h* (any :h) :s* (any :s) :w* (any :w) :A* (any :A) :D* (any :D) :H* (any :H) :S* (any :S) :W* (any :W)}) (setdyn *peg-grammar* default-peg-grammar) ### ### ### Evaluation and Compilation ### ### (defdyn *syspath* "Path of directory to load system modules from.") # Initialize syspath (each [k v] (partition 2 (tuple/slice boot/args 2)) (case k "JANET_PATH" (setdyn *syspath* v))) (defn make-env `Create a new environment table. The new environment will inherit bindings from the parent environment, but new bindings will not pollute the parent environment.` [&opt parent] (def parent (if parent parent root-env)) (def newenv (table/setproto @{} parent)) newenv) (defdyn *err-color* "Whether or not to turn on error coloring in stacktraces and other error messages.") (defn bad-parse "Default handler for a parse error." [p where] (def ec (dyn *err-color*)) (def [line col] (:where p)) (eprint (if ec "\e[31m" "") where ":" line ":" col ": parse error: " (:error p) (if ec "\e[0m")) (eflush)) (defn warn-compile "Default handler for a compile warning." [msg level where &opt line col] (def ec (dyn *err-color*)) (eprin (if ec "\e[33m" "") where ":" line ":" col ": compile warning (" level "): ") (eprint msg (if ec "\e[0m")) (eflush)) (defn bad-compile "Default handler for a compile error." [msg macrof where &opt line col] (def ec (dyn *err-color*)) (eprin (if ec "\e[31m" "") where ":" line ":" col ": compile error: ") (if macrof (debug/stacktrace macrof msg "") (eprint msg (if ec "\e[0m"))) (eflush)) (defn curenv ``Get the current environment table. Same as `(fiber/getenv (fiber/current))`. If `n` is provided, gets the nth prototype of the environment table.`` [&opt n] (var e (fiber/getenv (fiber/current))) (if n (repeat n (if (= nil e) (break)) (set e (table/getproto e)))) e) (def- lint-levels {:none 0 :relaxed 1 :normal 2 :strict 3 :all math/inf}) (defn run-context ``` Run a context. This evaluates expressions in an environment, and encapsulates the parsing, compilation, and evaluation. Returns `(in environment :exit-value environment)` when complete. `opts` is a table or struct of options. The options are as follows: * `:chunks` -- callback to read into a buffer - default is getline * `:on-parse-error` -- callback when parsing fails - default is bad-parse * `:env` -- the environment to compile against - default is the current env * `:source` -- source path for better errors (use keywords for non-paths) - default is `:` * `:on-compile-error` -- callback when compilation fails - default is bad-compile * `:on-compile-warning` -- callback for any linting error - default is warn-compile * `:evaluator` -- callback that executes thunks. Signature is (evaluator thunk source env where) * `:on-status` -- callback when a value is evaluated - default is debug/stacktrace. * `:fiber-flags` -- what flags to wrap the compilation fiber with. Default is :ia. * `:expander` -- an optional function that is called on each top level form before being compiled. * `:parser` -- provide a custom parser that implements the same interface as Janet's built-in parser. * `:read` -- optional function to get the next form, called like `(read env source)`. Overrides all parsing. ``` [opts] (def {:env env :chunks chunks :on-status onstatus :on-compile-error on-compile-error :on-compile-warning on-compile-warning :on-parse-error on-parse-error :fiber-flags guard :evaluator evaluator :source default-where :parser parser :read read :expander expand} opts) (default env (or (fiber/getenv (fiber/current)) @{})) (default chunks (fn chunks [buf p] (getline "" buf env))) (default onstatus debug/stacktrace) (default on-compile-error bad-compile) (default on-compile-warning warn-compile) (default on-parse-error bad-parse) (default evaluator (fn evaluate [x &] (x))) (default default-where :) (default guard :ydt) (var where default-where) (if (string? where) (put env *current-file* where)) # Evaluate 1 source form in a protected manner (def lints @[]) (defn eval1 [source &opt l c] (def source (if expand (expand source) source)) (var good true) (var resumeval nil) (def f (fiber/new (fn [] (array/clear lints) (def res (compile source env where lints)) (unless (empty? lints) # Convert lint levels to numbers. (def levels (get env *lint-levels* lint-levels)) (def lint-error (get env *lint-error*)) (def lint-warning (get env *lint-warn*)) (def lint-error (or (get levels lint-error lint-error) 0)) (def lint-warning (or (get levels lint-warning lint-warning) 2)) (each [level line col msg] lints (def lvl (get lint-levels level 0)) (cond (<= lvl lint-error) (do (set good false) (on-compile-error msg nil where (or line l) (or col c))) (<= lvl lint-warning) (on-compile-warning msg level where (or line l) (or col c))))) (when good (if (= (type res) :function) (evaluator res source env where) (do (set good false) (def {:error err :line line :column column :fiber errf} res) (on-compile-error err errf where (or line l) (or column c)))))) guard env)) (while (fiber/can-resume? f) (def res (resume f resumeval)) (when good (set resumeval (onstatus f res))))) # Reader version (when read (forever (if (in env :exit) (break)) (eval1 (read env where))) (break (in env :exit-value env))) # The parser object (def p (or parser (parser/new))) (def p-consume (p :consume)) (def p-produce (p :produce)) (def p-status (p :status)) (def p-has-more (p :has-more)) (defn parse-err "Handle parser error in the correct environment" [p where] (def f (coro (on-parse-error p where))) (fiber/setenv f env) (resume f)) (defn produce [] (def tup (p-produce p true)) [(in tup 0) ;(tuple/sourcemap tup)]) # Loop (def buf @"") (var parser-not-done true) (while parser-not-done (if (env :exit) (break)) (buffer/clear buf) (match (chunks buf p) :cancel (do # A :cancel chunk represents a cancelled form in the REPL, so reset. (:flush p) (buffer/clear buf)) [:source new-where] (do (set where new-where) (if (string? new-where) (put env *current-file* new-where))) (do (var pindex 0) (def len (length buf)) (when (= len 0) (:eof p) (set parser-not-done false)) (while (> len pindex) (+= pindex (p-consume p buf pindex)) (while (p-has-more p) (eval1 ;(produce)) (if (env :exit) (break))) (when (= (p-status p) :error) (parse-err p where) (if (env :exit) (break))))))) # Check final parser state (unless (env :exit) (while (p-has-more p) (eval1 ;(produce)) (if (env :exit) (break))) (when (= (p-status p) :error) (parse-err p where))) (put env :exit nil) (in env :exit-value env)) (defn quit ``Tries to exit from the current repl or run-context. Does not always exit the application. Works by setting the :exit dynamic binding to true. Passing a non-nil `value` here will cause the outer run-context to return that value.`` [&opt value] (setdyn :exit true) (setdyn :exit-value value) nil) (defn eval ``Evaluates a form in the current environment. If more control over the environment is needed, use `run-context`. Optionally pass in an `env` table with available bindings.`` [form &opt env] (def res (compile form env :eval)) (if (= (type res) :function) (res) (error (get res :error)))) (defn parse `Parse a string and return the first value. For complex parsing, such as for a repl with error handling, use the parser api.` [str] (let [p (parser/new)] (parser/consume p str) (if (= :error (parser/status p)) (error (parser/error p))) (parser/eof p) (if (parser/has-more p) (parser/produce p) (if (= :error (parser/status p)) (error (parser/error p)) (error "no value"))))) (defn parse-all `Parse a string and return all parsed values. For complex parsing, such as for a repl with error handling, use the parser api.` [str] (let [p (parser/new) ret @[]] (parser/consume p str) (if (= :error (parser/status p)) (error (parser/error p))) (parser/eof p) (while (parser/has-more p) (array/push ret (parser/produce p))) (if (= :error (parser/status p)) (error (parser/error p)) ret))) (defn eval-string ``Evaluates a string in the current environment. If more control over the environment is needed, use `run-context`. Optionally pass in an `env` table with available bindings.`` [str &opt env] (var ret nil) (each x (parse-all str) (set ret (eval x env))) ret) (def load-image-dict ``A table used in combination with `unmarshal` to unmarshal byte sequences created by `make-image`, such that `(load-image bytes)` is the same as `(unmarshal bytes load-image-dict)`.`` @{}) (def make-image-dict ``A table used in combination with `marshal` to marshal code (images), such that `(make-image x)` is the same as `(marshal x make-image-dict)`.`` @{}) (defmacro comptime "Evals x at compile time and returns the result. Similar to a top level unquote." [x] (def y (eval x)) y) (defmacro compif "Check the condition `cnd` at compile time -- if truthy, compile `tru`, else compile `fals`." [cnd tru &opt fals] (if (eval cnd) tru fals)) (defmacro compwhen "Check the condition `cnd` at compile time -- if truthy, compile `(upscope ;body)`, else compile nil." [cnd & body] (if (eval cnd) ~(upscope ,;body))) (defn make-image ``Create an image from an environment returned by `require`. Returns the image source as a string.`` [env] (marshal env make-image-dict)) (defn load-image "The inverse operation to `make-image`. Returns an environment." [image] (unmarshal image load-image-dict)) (defn- check-dyn-relative [x] (if (string/has-prefix? "@" x) x)) (defn- check-relative [x] (if (string/has-prefix? "." x) x)) # Don't try to preload absolute or relative paths (defn- check-preloadable [x] (if-not (or (string/has-prefix? "/" x) (string/find "." x) (string/find "@" x)) x)) (defn- check-is-dep [x] (unless (or (string/has-prefix? "/" x) (string/has-prefix? "@" x) (string/has-prefix? "." x)) x)) (defn- check-project-relative [x] (if (string/has-prefix? "/" x) x)) (defdyn *module-cache* "Dynamic binding for overriding `module/cache`") (defdyn *module-paths* "Dynamic binding for overriding `module/paths`") (defdyn *module-loading* "Dynamic binding for overriding `module/loading`") (defdyn *module-loaders* "Dynamic binding for overriding `module/loaders`") (defdyn *module-make-env* "Dynamic binding for creating new environments for `import`, `require`, and `dofile`. Overrides `make-env`.") (def module/cache "A table, mapping loaded module identifiers to their environments." @{}) (def module/paths ``` The list of paths to look for modules, templated for `module/expand-path`. Each element is a two-element tuple, containing the path template and a keyword :source, :native, or :image indicating how `require` should load files found at these paths. A tuple can also contain a third element, specifying a filter that prevents `module/find` from searching that path template if the filter doesn't match the input path. The filter can be a string or a predicate function, and is often a file extension, including the period. ``` @[]) (defn module/add-paths ``` Add paths to `module/paths` for a given loader such that the generated paths behave like other module types, including relative imports and syspath imports. `ext` is the file extension to associate with this module type, including the dot. `loader` is the keyword name of a loader in `module/loaders`. The parameter `match-exact-path` will allow users to import files with this extension directly with a relative or absolute path. Returns the modified `module/paths`. ``` [ext loader] (def mp (dyn *module-paths* module/paths)) (defn- find-prefix [pre] (or (find-index |(and (string? ($ 0)) (string/has-prefix? pre ($ 0))) mp) 0)) (def dyn-index (find-prefix ":@all:")) (array/insert mp dyn-index [(string ":@all:" ext) loader check-dyn-relative]) (def all-index (find-prefix ".:all:")) (array/insert mp all-index [(string ".:all:" ext) loader check-project-relative]) (def sys-index (find-prefix ":sys:")) (array/insert mp sys-index [(string ":sys:/:all:" ext) loader check-is-dep]) (def curall-index (find-prefix ":cur:/:all:")) (array/insert mp curall-index [(string ":cur:/:all:" ext) loader check-relative]) mp) (defn module/add-file-extension ``` Add paths to `module/paths` for a given file extension such that the programmer can import a module by relative or absolute path from the current working directory. Returns the modified `module/paths`. ``` [ext loader] (assert (string/has-prefix? "." ext) "file extension must have . prefix") (def mp (dyn *module-paths* module/paths)) (array/insert mp 0 [":all:" loader (fn :check-ext [x] (string/has-suffix? ext x))]) mp) # Don't expose this externally yet - could break if custom module/paths is setup. (defn module/add-syspath ``` Add a custom syspath to `module/paths` by duplicating all entries that being with `:sys:` and adding duplicates with a specific path prefix instead. ``` [path] (def copies @[]) (var last-index 0) (def mp (dyn *module-paths* module/paths)) (eachp [index entry] mp (def pattern (first entry)) (when (and (string? pattern) (string/has-prefix? ":sys:/" pattern)) (set last-index index) (array/push copies [(string/replace ":sys:" path pattern) ;(drop 1 entry)]))) (array/insert mp (+ 1 last-index) ;copies) mp) (module/add-paths ":native:" :native) (module/add-paths "/init.janet" :source) (module/add-paths ".janet" :source) (module/add-paths ".jimage" :image) (module/add-file-extension ".janet" :source) (module/add-file-extension ".jimage" :source) # These obviously won't work on all platforms, but if a user explicitly # tries to import them, we may as well try. (module/add-file-extension ".so" :native) (module/add-file-extension ".dll" :native) (array/insert module/paths 0 [(fn is-cached [path] (if (in (dyn *module-cache* module/cache) path) path)) :preload check-preloadable]) # Version of fexists that works even with a reduced OS (defn- fexists [path] (compif (dyn 'os/stat) (= :file (os/stat path :mode)) (when-let [f (file/open path :rb)] (def res (try (do (file/read f 1) true) ([err] nil))) (file/close f) res))) (defn- mod-filter [x path] (case (type x) :nil path :string (string/has-suffix? x path) (x path))) (defn module/find ``` Try to match a module or path name from the patterns in `module/paths`. Returns a tuple (fullpath kind) where the kind is one of :source, :native, or :image if the module is found, otherwise a tuple with nil followed by an error message. ``` [path &opt find-all] (var ret nil) (def mp (dyn *module-paths* module/paths)) (def all-matches (if find-all @[])) (each [p mod-kind checker] mp (when (mod-filter checker path) (if (function? p) (when-let [res (p path)] (set ret [res mod-kind]) (if find-all (array/push all-matches ret) (break))) (do (def fullpath (string (module/expand-path path p))) (when (fexists fullpath) (set ret [fullpath mod-kind]) (if find-all (array/push all-matches ret) (break))))))) (if find-all (break all-matches)) (if ret ret (let [expander (fn :expander [[t _ chk]] (when (string? t) (when (mod-filter chk path) (module/expand-path path t)))) paths (filter identity (map expander mp)) str-parts (interpose "\n " paths)] [nil (string "could not find module " path ":\n " ;str-parts)]))) (def module/loading `A table, mapping currently loading modules to true. Used to prevent circular dependencies.` @{}) (defn module/value ``Given a module table, get the value bound to a symbol `sym`. If `private` is truthy, will also resolve private module symbols. If no binding is found, will return nil.`` [module sym &opt private] (def entry (get module sym)) (if entry (let [v (in entry :value) r (in entry :ref) p (in entry :private)] (if p (if private nil (break))) (if (and r (array? r)) (get r 0) v)))) (def debugger-env "An environment that contains dot prefixed functions for debugging." @{}) (var- debugger-on-status-var nil) (defn debugger "Run a repl-based debugger on a fiber. Optionally pass in a level to differentiate nested debuggers." [fiber &opt level] (default level 1) (def nextenv (make-env (fiber/getenv fiber))) (put nextenv :fiber fiber) (put nextenv :debug-level level) (put nextenv :signal (fiber/last-value fiber)) (merge-into nextenv debugger-env) (defn debugger-chunks [buf p] (def status (:state p :delimiters)) (def c ((:where p) 0)) (def prpt (string "debug[" level "]:" c ":" status "> ")) (getline prpt buf nextenv)) (eprint "entering debug[" level "] - (quit) to exit") (flush) (run-context {:chunks debugger-chunks :on-status (debugger-on-status-var nextenv (+ 1 level) true) :env nextenv}) (eprint "exiting debug[" level "]") (flush) (nextenv :resume-value)) (defn debugger-on-status "Create a function that can be passed to `run-context`'s `:on-status` argument that will drop into a debugger on errors. The debugger will only start on abnormal signals if the env table has the `:debug` dyn set to a truthy value." [env &opt level is-repl] (default level 1) (fn :debugger [f x] (def fs (fiber/status f)) (if (= :dead fs) (when is-repl (put env '_ @{:value x}) (def pf (get env *pretty-format* "%q")) (try (printf pf x) ([e] (eprintf "bad pretty format %v: %v" pf e) (eflush))) (flush)) (do (debug/stacktrace f x "") (eflush) (if (get env :debug) (debugger f level)))))) (set debugger-on-status-var debugger-on-status) (defn dofile ``Evaluate a file, file path, or stream and return the resulting environment. :env, :expander, :source, :evaluator, :read, and :parser are passed through to the underlying `run-context` call. If `exit` is true, any top level errors will trigger a call to `(os/exit 1)` after printing the error.`` [path &named exit env source expander evaluator read parser] (def f (case (type path) :core/file path :core/stream path (file/open path :rb))) (def path-is-file (= f path)) (default env ((dyn *module-make-env* make-env))) (def spath (string path)) (put env :source (or source (if-not path-is-file spath path))) (var exit-error nil) (var exit-fiber nil) (defn chunks [buf _] (:read f 4096 buf)) (defn bp [&opt x y] (when exit (bad-parse x y) (os/exit 1)) (put env :exit true) (def buf @"") (with-dyns [*err* buf] (bad-parse x y)) (set exit-error (string/slice buf 0 -2))) (defn bc [&opt x y z a b] (when exit (bad-compile x y z a b) (os/exit 1)) (put env :exit true) (def buf @"") (with-dyns [*err* buf] (bad-compile x nil z a b)) (set exit-error (string/slice buf 0 -2)) (set exit-fiber y)) (unless f (error (string "could not find file " path))) (def nenv (run-context {:env env :chunks chunks :on-parse-error bp :on-compile-error bc :on-status (fn [f x] (when (not= (fiber/status f) :dead) (when exit (debug/stacktrace f x "") (eflush) (os/exit 1)) (if (get env :debug) ((debugger-on-status env) f x) (do (put env :exit true) (set exit-error x) (set exit-fiber f))))) :evaluator evaluator :expander expander :read read :parser parser :source (or source (if path-is-file : spath))})) (if-not path-is-file (:close f)) (when exit-error (if exit-fiber (propagate exit-error exit-fiber) (error exit-error))) nenv) (def module/loaders ``A table of loading method names to loading functions. This table lets `require` and `import` load many different kinds of files as modules.`` @{:native (fn native-loader [path &] (native path ((dyn *module-make-env* make-env)))) :source (fn source-loader [path args] (def ml (dyn *module-loading* module/loading)) (put ml path true) (defer (put ml path nil) (dofile path ;args))) :preload (fn preload-loader [path & args] (def mc (dyn *module-cache* module/cache)) (when-let [m (in mc path)] (if (function? m) (set (mc path) (m path ;args)) m))) :image (fn image-loader [path &] (load-image (slurp path)))}) (defn- require-1 [path args kargs] (def [fullpath mod-kind] (if-let [loader (get kargs :loader)] [path loader] (module/find path))) (unless fullpath (error mod-kind)) (def mc (dyn *module-cache* module/cache)) (def ml (dyn *module-loading* module/loading)) (def mls (dyn *module-loaders* module/loaders)) (if-let [check (if-not (get kargs :fresh) (in mc fullpath))] check (if (get ml fullpath) (error (string "circular dependency " fullpath " detected")) (do (def loader (if (keyword? mod-kind) (get mls mod-kind) mod-kind)) (unless loader (error (string "module type " mod-kind " unknown"))) (def env (loader fullpath args)) (put mc fullpath env) env)))) (defn require ``Require a module with the given name. Will search all of the paths in `module/paths`. Returns the new environment returned from compiling and running the file.`` [path & args] (require-1 path args (struct ;args))) (defn merge-module ``Merge a module source into the `target` environment with a `prefix`, as with the `import` macro. This lets users emulate the behavior of `import` with a custom module table. If `export` is truthy, then merged functions are not marked as private. Returns the modified target environment. If a tuple or array `only` is passed, only merge keys in `only`.`` [target source &opt prefix export only] (def only-set (if only (invert only))) (loop [[k v] :pairs source :when (symbol? k) :when (not (v :private)) :when (or (not only) (in only-set k))] (def newv (table/setproto @{:private (not export)} v)) (put target (symbol prefix k) newv)) target) (defn import* ``Function form of `import`. Same parameters, but the path and other symbol parameters should be strings instead.`` [path & args] (def env (curenv)) (def kargs (table ;args)) (def {:as as :prefix prefix :export ep :only only} kargs) (def newenv (require-1 path args kargs)) (def prefix (or (and as (string as "/")) prefix (string (first (string/split "." (last (string/split "/" path)))) "/"))) (merge-module env newenv prefix ep only)) (defmacro import ``Import a module. First requires the module, and then merges its symbols into the current environment, prepending a given prefix as needed. (use the :as or :prefix option to set a prefix). If no prefix is provided, use the name of the module as a prefix. One can also use "`:export true`" to re-export the imported symbols. If "`:exit true`" is given as an argument, any errors encountered at the top level in the module will cause `(os/exit 1)` to be called. Dynamic bindings will NOT be imported. Use :fresh with a truthy value to bypass the module cache. Use `:only [foo bar baz]` to only import select bindings into the current environment.`` [path & args] (assertf (even? (length args)) "args should have even length: %n" args) (def ps (partition 2 args)) (def argm (mapcat (fn [[k v]] (assertf (keyword? k) "expected keyword, got %s: %n" (type k) k) [k (case k :as (string v) :only ~(quote ,v) v)]) ps)) (tuple import* (string path) ;argm)) (defmacro use ``Similar to `import`, but imported bindings are not prefixed with a module identifier. Can also import multiple modules in one shot.`` [& modules] ~(do ,;(map |~(,import* ,(string $) :prefix "") modules))) ### ### ### Documentation ### ### (defn- env-walk [pred &opt env local] (default env (fiber/getenv (fiber/current))) (def envs @[]) (do (var e env) (while e (array/push envs e) (set e (table/getproto e)) (if local (break)))) (def ret-set @{}) (loop [envi :in envs k :keys envi :when (pred k)] (put ret-set k true)) (sort (keys ret-set))) (defn all-bindings ``Get all symbols available in an environment. Defaults to the current fiber's environment. If `local` is truthy, will not show inherited bindings (from prototype tables).`` [&opt env local] (env-walk symbol? env local)) (defn all-dynamics ``Get all dynamic bindings in an environment. Defaults to the current fiber's environment. If `local` is truthy, will not show inherited bindings (from prototype tables).`` [&opt env local] (env-walk keyword? env local)) (defdyn *doc-width* "Width in columns to print documentation printed with `doc-format`.") (defdyn *doc-color* "Whether or not to colorize documentation printed with `doc-format`.") (defn doc-format `Reformat a docstring to wrap a certain width. Docstrings can either be plaintext or a subset of markdown. This allows a long single line of prose or formatted text to be a well-formed docstring. Returns a buffer containing the formatted text.` [str &opt width indent colorize] (default indent 4) (def max-width (- (or width (dyn *doc-width* 80)) 8)) (def has-color (if (not= nil colorize) colorize (dyn *doc-color*))) # Terminal codes for emission/tokenization (def delimiters (if has-color {:code ["\e[97m" "\e[39m"] :italics ["\e[4m" "\e[24m"] :bold ["\e[1m" "\e[22m"]} {:code ["`" "`"] :italics ["*" "*"] :bold ["**" "**"]})) (def modes @{}) (defn toggle-mode [mode] (def active (get modes mode)) (def delims (get delimiters mode)) (put modes mode (not active)) (delims (if active 1 0))) # Parse state (var cursor 0) # indexes into string for parsing (var stack @[]) # return value for this block. # Traversal helpers (defn c [] (get str cursor)) (defn cn [n] (get str (+ n cursor))) (defn c++ [] (let [ret (get str cursor)] (++ cursor) ret)) (defn c+=n [n] (let [ret (get str cursor)] (+= cursor n) ret)) # skip* functions return number of characters matched and advance the cursor. (defn skipwhite [] (def x cursor) (while (= (c) (chr " ")) (++ cursor)) (- cursor x)) (defn skipline [] (def x cursor) (while (let [y (c)] (and y (not= y (chr "\n")))) (++ cursor)) (c++) (- cursor x)) # Detection helpers - return number of characters matched (defn ul? [] (let [x (c) x1 (cn 1)] (and (= x1 (chr " ")) (or (= x (chr "*")) (= x (chr "-"))) 2))) (defn ol? [] (def old cursor) (while (and (>= (c) (chr "0")) (<= (c) (chr "9"))) (c++)) (let [c1 (c) c2 (cn 1) c* cursor] (set cursor old) (if (and (= c1 (chr ".")) (= c2 (chr " "))) (- c* cursor -2)))) (defn fcb? [] (if (= (chr "`") (c) (cn 1) (cn 2)) 3)) (defn nl? [] (= (chr "\n") (c))) # Parse helper # parse-* functions push nodes to `stack`, and return # the indentation they leave the cursor on. (var parse-blocks nil) # mutual recursion (defn getslice [from to] (def to (min to (length str))) (string/slice str from to)) (defn push [x] (array/push stack x)) (defn parse-list [bullet-check initial indent] (def temp-stack @[initial]) (def old-stack stack) (set stack temp-stack) (var current-indent indent) (while (and (c) (>= current-indent indent)) (def item-indent (when-let [x (bullet-check)] (c+=n x) (+ indent (skipwhite) x))) (unless item-indent (set current-indent (skipwhite)) (break)) (def item-stack @[]) (set stack item-stack) (set current-indent (parse-blocks item-indent)) (set stack temp-stack) (push item-stack)) (set stack old-stack) (push temp-stack) current-indent) (defn add-codeblock [indent start end] (def replace-chunk (string "\n" (string/repeat " " indent))) (push @[:cb (string/replace-all replace-chunk "\n" (getslice start end))]) (skipline) (skipwhite)) (defn parse-fcb [indent] (c+=n 3) (skipline) (c+=n indent) (def start cursor) (var end cursor) (while (c) (if (fcb?) (break)) (skipline) (set end cursor) (skipwhite)) (add-codeblock indent start end)) (defn parse-icb [indent] (var current-indent indent) (def start cursor) (var end cursor) (while (c) (skipline) (set end cursor) (set current-indent (skipwhite)) (if (< current-indent indent) (break))) (add-codeblock indent start end)) (defn tokenize-line [line] (def tokens @[]) (def token @"") (var token-length 0) (defn delim [mode] (def d (toggle-mode mode)) (if-not has-color (+= token-length (length d))) (buffer/push token d)) (defn endtoken [] (if (first token) (array/push tokens [(string token) token-length])) (buffer/clear token) (set token-length 0)) (forv i 0 (length line) (def b (get line i)) (cond (or (= b (chr "\n")) (= b (chr " "))) (endtoken) (= b (chr "`")) (delim :code) (not (modes :code)) (cond (= b (chr `\`)) (do (++ token-length) (buffer/push token (get line (++ i)))) (= b (chr "*")) (if (= (chr "*") (get line (+ i 1))) (do (++ i) (delim :bold)) (delim :italics)) (do (++ token-length) (buffer/push token b))) (do (++ token-length) (buffer/push token b)))) (endtoken) (tuple/slice tokens)) (set parse-blocks (fn parse-blocks [indent] (var new-indent indent) (var p-start nil) (var p-end nil) (defn p-line [] (unless p-start (set p-start cursor)) (skipline) (set p-end cursor) (set new-indent (skipwhite))) (defn finish-p [] (when (and p-start (> p-end p-start)) (push (tokenize-line (getslice p-start p-end))) (set p-start nil))) (while (and (c) (>= new-indent indent)) (cond (nl?) (do (finish-p) (c++) (set new-indent (skipwhite))) (ul?) (do (finish-p) (set new-indent (parse-list ul? :ul new-indent))) (ol?) (do (finish-p) (set new-indent (parse-list ol? :ol new-indent))) (fcb?) (do (finish-p) (set new-indent (parse-fcb new-indent))) (>= new-indent (+ 4 indent)) (do (finish-p) (set new-indent (parse-icb new-indent))) (p-line))) (finish-p) new-indent)) # Handle first line specially for defn, defmacro, etc. (when (= (chr "(") (in str 0)) (skipline) (def first-line (string/slice str 0 (- cursor 1))) (def fl-open (if has-color "\e[97m" "")) (def fl-close (if has-color "\e[39m" "")) (push [[(string fl-open first-line fl-close) (length first-line)]])) (parse-blocks 0) # Emission state (def buf @"") (var current-column 0) # Emission (defn emit-indent [indent] (def delta (- indent current-column)) (when (< 0 delta) (buffer/push buf (string/repeat " " delta)) (set current-column indent))) (defn emit-nl [&opt indent] (buffer/push buf "\n") (set current-column 0)) (defn emit-word [word indent &opt len] (def last-byte (last buf)) (when (and last-byte (not= last-byte (chr "\n")) (not= last-byte (chr " "))) (buffer/push buf " ") (++ current-column)) (default len (length word)) (when (and indent (> (+ 1 current-column len) max-width)) (emit-nl) (emit-indent indent)) (buffer/push buf word) (+= current-column len)) (defn emit-code [code indent] (def replacement (string "\n" (string/repeat " " (+ 4 indent)))) (emit-indent (+ 4 indent)) (buffer/push buf (string/replace-all "\n" replacement code)) (if (= (chr "\n") (last code)) (set current-column 0) (emit-nl))) (defn emit-node [el indent] (emit-indent indent) (if (tuple? el) (let [rep (string "\n" (string/repeat " " indent))] (each [word len] el (emit-word (string/replace-all "\n" rep word) indent len)) (emit-nl)) (case (first el) :ul (for i 1 (length el) (if (> i 1) (emit-indent indent)) (emit-word "* " nil) (each subel (get el i) (emit-node subel (+ 2 indent)))) :ol (for i 1 (length el) (if (> i 1) (emit-indent indent)) (def lab (string/format "%d. " i)) (emit-word lab nil) (each subel (get el i) (emit-node subel (+ (length lab) indent)))) :cb (emit-code (get el 1) indent)))) (each el stack (emit-nl) (emit-node el indent)) buf) (defn- print-index "Print bindings in the current environment given a filter function." [fltr] (def bindings (filter fltr (all-bindings))) (def dynamics (map describe (filter fltr (all-dynamics)))) (print) (print (doc-format (string "Bindings:\n\n" (string/join bindings " ")) nil nil false)) (print) (print (doc-format (string "Dynamics:\n\n" (string/join dynamics " ")) nil nil false)) (print "\n Use (doc sym) for more information on a binding.\n")) (defn- print-module-entry [x] (def bind-type (string " " (cond (x :redef) (type (in (x :ref) 0)) (x :ref) (string :var " (" (type (in (x :ref) 0)) ")") (x :macro) :macro (x :module) (string :module " (" (x :kind) ")") (type (x :value))) "\n")) (def sm (x :source-map)) (def d (x :doc)) (print "\n\n" bind-type (when-let [[path line col] sm] (string " " path (when (and line col) (string " on line " line ", column " col)))) (when sm "\n") (if d (doc-format d) "\n no documentation found.\n") "\n")) (defn- print-special-form-entry [x] (print "\n\n" " special form\n\n" " (" x " ...)\n\n" " See https://janet-lang.org/docs/specials.html\n\n")) (defn doc* "Get the documentation for a symbol in a given environment. Function form of `doc`." [&opt sym] (cond (string? sym) (print-index (fn [x] (string/find sym x))) sym (do (def x (dyn sym)) (if (not x) (if (index-of sym '[break def do fn if quasiquote quote set splice unquote upscope var while]) (print-special-form-entry sym) (do (def [fullpath mod-kind] (module/find (string sym))) (if-let [mod-env (in module/cache fullpath)] (print-module-entry {:module true :kind mod-kind :source-map [fullpath nil nil] :doc (in mod-env :doc)}) (print "symbol " sym " not found.")))) (print-module-entry x))) # else (print-index identity))) (defmacro doc ``Shows documentation for the given symbol, or can show a list of available bindings. If `sym` is a symbol, will look for documentation for that symbol. If `sym` is a string or is not provided, will show all lexical and dynamic bindings in the current environment containing that string (all bindings will be shown if no string is given).`` [&opt sym] ~(,doc* ',sym)) (defn doc-of `Searches all loaded modules in module/cache for a given binding and prints out its documentation. This does a search by value instead of by name. Returns nil.` [x] (var found false) (loop [module-set :in [[root-env] module/cache] module :in module-set value :in module] (let [check (or (get value :ref) (get value :value))] (when (= check x) (print-module-entry value) (set found true) (break)))) (if-not found (print "documentation for value " x " not found."))) ### ### ### Debugger ### ### (defn .fiber "Get the current fiber being debugged." [] (dyn :fiber)) (defn .signal "Get the current signal being debugged." [] (dyn :signal)) (defn .stack "Print the current fiber stack." [] (print) (with-dyns [*err-color* false] (debug/stacktrace (.fiber) (.signal) "")) (print)) (defn .frame "Show a stack frame" [&opt n] (def stack (debug/stack (.fiber))) (in stack (or n 0))) (defn .locals "Show local bindings" [&opt n] (get (.frame n) :locals)) (defn .fn "Get the current function." [&opt n] (in (.frame n) :function)) (defn .slots "Get an array of slots in a stack frame." [&opt n] (in (.frame n) :slots)) (defn .slot "Get the value of the nth slot." [&opt nth frame-idx] (in (.slots frame-idx) (or nth 0))) # Conditional compilation for disasm (compwhen (dyn 'disasm) (defn .disasm "Gets the assembly for the current function." [&opt n] (def frame (.frame n)) (def func (frame :function)) (disasm func)) (defn .bytecode "Get the bytecode for the current function." [&opt n] ((.disasm n) :bytecode)) (defn .ppasm "Pretty prints the assembly for the current function." [&opt n] (def frame (.frame n)) (def func (frame :function)) (def dasm (disasm func)) (def bytecode (in dasm :bytecode)) (def pc (frame :pc)) (def sourcemap (in dasm :sourcemap)) (var last-loc [-2 -2]) (eprint "\n signal: " (.signal)) (eprint " status: " (fiber/status (.fiber))) (eprint " function: " (get dasm :name "") " [" (in dasm :source "") "]") (when-let [constants (dasm :constants)] (eprintf " constants: %.4q" constants)) (eprintf " slots: %.4q\n" (frame :slots)) (when-let [src-path (in dasm :source)] (when (and (fexists src-path) sourcemap) (defn dump [src cur] (def offset 5) (def beg (max 1 (- cur offset))) (def lines (array/concat @[""] (string/split "\n" src))) (def end (min (+ cur offset) (length lines))) (def digits (inc (math/floor (math/log10 end)))) (def fmt-str (string "%" digits "d: %s")) (for i beg end (eprin " ") (eprin (if (= i cur) "> " " ")) (eprintf fmt-str i (get lines i)))) (let [[sl _] (sourcemap pc)] (dump (slurp src-path) sl) (eprint)))) (def padding (string/repeat " " 20)) (loop [i :range [0 (length bytecode)] :let [instr (bytecode i)]] (eprin (if (= (tuple/type instr) :brackets) "*" " ")) (eprin (if (= i pc) "> " " ")) (eprinf "%.20s" (string (string/join (map string instr) " ") padding)) (when sourcemap (let [[sl sc] (sourcemap i) loc [sl sc]] (when (not= loc last-loc) (set last-loc loc) (eprin " # line " sl ", column " sc)))) (eprint)) (eprint)) (defn .breakall "Set breakpoints on all instructions in the current function." [&opt n] (def fun (.fn n)) (def bytecode (.bytecode n)) (forv i 0 (length bytecode) (debug/fbreak fun i)) (eprint "set " (length bytecode) " breakpoints in " fun)) (defn .clearall "Clear all breakpoints on the current function." [&opt n] (def fun (.fn n)) (def bytecode (.bytecode n)) (forv i 0 (length bytecode) (debug/unfbreak fun i)) (eprint "cleared " (length bytecode) " breakpoints in " fun))) (defn .source "Show the source code for the function being debugged." [&opt n] (def frame (.frame n)) (def s (frame :source)) (def all-source (slurp s)) (eprint "\n" all-source "\n")) (defn .break "Set breakpoint at the current pc." [] (def frame (.frame)) (def fun (frame :function)) (def pc (frame :pc)) (debug/fbreak fun pc) (eprint "set breakpoint in " fun " at pc=" pc)) (defn .clear "Clear the current breakpoint." [] (def frame (.frame)) (def fun (frame :function)) (def pc (frame :pc)) (debug/unfbreak fun pc) (eprint "cleared breakpoint in " fun " at pc=" pc)) (defn .next "Go to the next breakpoint." [&opt n] (var res nil) (forv i 0 (or n 1) (set res (resume (.fiber)))) res) (defn .nextc "Go to the next breakpoint, clearing the current breakpoint." [&opt n] (.clear) (.next n)) (defn .step "Execute the next n instructions." [&opt n] (var res nil) (forv i 0 (or n 1) (set res (debug/step (.fiber)))) res) (def- debugger-keys (filter (partial string/has-prefix? ".") (keys root-env))) (each k debugger-keys (put debugger-env k (root-env k)) (put root-env k nil)) ### ### ### REPL ### ### (defn repl ``Run a repl. The first parameter is an optional function to call to get a chunk of source code that should return nil for end of file. The second parameter is a function that is called when a signal is caught. One can provide an optional environment table to run the repl in, as well as an optional parser or read function to pass to `run-context`.`` [&opt chunks onsignal env parser read] (default env (make-env)) (default chunks (fn :chunks [buf p] (def custom-prompt (get env *repl-prompt*)) (def repl-prompt (if custom-prompt (custom-prompt p) (string "repl:" ((:where p) 0) ":" (:state p :delimiters) "> "))) (getline repl-prompt buf env))) (run-context {:env env :chunks chunks :on-status (or onsignal (debugger-on-status env 1 true)) :parser parser :read read :source :repl})) ### ### ### Extras ### ### (compwhen (dyn 'ev/go) (defn net/close "Alias for `ev/close`." [stream] (ev/close stream)) (defn ev/call ``` Call a function asynchronously. Returns a task fiber that is scheduled to run the function. ``` [f & args] (ev/go (fn :call [&] (f ;args)))) (defmacro ev/spawn `` Run some code in a new task fiber. This is shorthand for `(ev/go (fn [] ;body))`." `` [& body] ~(,ev/go (fn :spawn [&] ,;body))) (defmacro ev/do-thread ``Run some code in a new thread. Suspends the current fiber until the thread is complete, and evaluates to nil.`` [& body] ~(,ev/thread (fn :do-thread [&] ,;body))) (defn- acquire-release [acq rel lock body] (def l (gensym)) ~(do (def ,l ,lock) (,acq ,l) (defer (,rel ,l) ,;body))) (defmacro ev/with-lock ``Run a body of code after acquiring a lock. Will automatically release the lock when done.`` [lock & body] (acquire-release ev/acquire-lock ev/release-lock lock body)) (defmacro ev/with-rlock ``Run a body of code after acquiring read access to an rwlock. Will automatically release the lock when done.`` [lock & body] (acquire-release ev/acquire-rlock ev/release-rlock lock body)) (defmacro ev/with-wlock ``Run a body of code after acquiring write access to an rwlock. Will automatically release the lock when done.`` [lock & body] (acquire-release ev/acquire-wlock ev/release-wlock lock body)) (defmacro ev/spawn-thread ``Run some code in a new thread. Like `ev/do-thread`, but returns nil immediately.`` [& body] ~(,ev/thread (fn :spawn-thread [&] ,;body) nil :n)) (defmacro ev/with-deadline `` Create a fiber to execute `body`, schedule the event loop to cancel the task (root fiber) associated with `body`'s fiber, and start `body`'s fiber by resuming it. The event loop will try to cancel the root fiber if `body`'s fiber has not completed after at least `sec` seconds. `sec` is a number that can have a fractional part. `` [sec & body] (with-syms [f] ~(let [,f (coro ,;body)] (,ev/deadline ,sec nil ,f) (,resume ,f)))) (defn- cancel-all [chan fibers reason] (each f fibers (ev/cancel f reason)) (let [n (length fibers)] (table/clear fibers) (repeat n (ev/take chan)))) (defn- wait-for-fibers [chan fibers] (defer (cancel-all chan fibers "parent canceled") (repeat (length fibers) (def [sig fiber] (ev/take chan)) (if (= sig :ok) (put fibers fiber nil) (do (cancel-all chan fibers "sibling canceled") (propagate (fiber/last-value fiber) fiber)))))) (defn ev/go-gather ``` Run a dyanmic number of fibers in parallel and resume the current fiber after they complete. Takes an array of functions or fibers, `thunks`, that will be run via `ev/go` in another task. Returns the gathered results in an array. ``` [thunks] (def fset @{}) (def chan (ev/chan)) (def results @[]) (each thunk thunks (def ftemp (ev/go thunk nil chan)) (array/push results ftemp) (put fset ftemp ftemp)) (wait-for-fibers chan fset) (for i 0 (length results) # avoid extra copy from map (set (results i) (fiber/last-value (in results i)))) results) (defmacro ev/gather `` Create and run a number of fibers in parallel (created from `bodies`) and resume the current fiber after they complete. Shorthand for `ev/go-gather`. Returns the gathered results in an array. `` [& bodies] ~(,ev/go-gather ,(seq [body :in bodies] ~(fn :ev/gather [] ,body))))) (compwhen (dyn 'net/listen) (defn net/server `` Starts a server with `net/listen`. Runs `net/accept-loop` asynchronously if `handler` is set and `type` is `:stream` (the default). It is invalid to set `handler` if `type` is `:datagram`. Returns the new server stream. `` [host port &opt handler type no-reuse] (assert (not (and (= type :datagram) handler)) "handler not supported for :datagram servers") (def s (net/listen host port type no-reuse)) (if handler (ev/go (fn [] (net/accept-loop s handler)))) s)) ### ### ### FFI Extra ### ### (defmacro delay "Lazily evaluate a series of expressions. Returns a function that returns the result of the last expression. Will only evaluate the body once, and then memoizes the result." [& forms] (def state (gensym)) (def loaded (gensym)) ~((fn :delay [] (var ,state nil) (var ,loaded nil) (fn [] (if ,loaded ,state (do (set ,loaded true) (set ,state (do ,;forms)))))))) (compwhen (dyn 'ffi/native) (defdyn *ffi-context* " Current native library for ffi/bind and other settings") (defn- default-mangle [name &] (string/replace-all "-" "_" name)) (defn ffi/context "Set the path of the dynamic library to implicitly bind, as well as other global state for ease of creating native bindings." [&opt native-path &named map-symbols lazy] (default map-symbols default-mangle) (def lib (if lazy nil (ffi/native native-path))) (def lazy-lib (if lazy (delay (ffi/native native-path)))) (setdyn *ffi-context* @{:native-path native-path :native lib :native-lazy lazy-lib :lazy lazy :map-symbols map-symbols})) (defmacro ffi/defbind-alias :flycheck "Generate bindings for native functions in a convenient manner. Similar to defbind but allows for the janet function name to be different than the FFI function." [name alias ret-type & body] (def real-ret-type (eval ret-type)) (def meta (slice body 0 -2)) (def arg-pairs (partition 2 (last body))) (def formal-args (map 0 arg-pairs)) (def type-args (map 1 arg-pairs)) (def computed-type-args (eval ~[,;type-args])) (if (dyn *flychecking*) (break ~(defn ,alias ,;meta [,;formal-args] nil))) (def {:native lib :lazy lazy :native-lazy llib :map-symbols ms} (assert (dyn *ffi-context*) "no ffi context found")) (def raw-symbol (ms name)) (defn make-sig [] (ffi/signature :default real-ret-type ;computed-type-args)) (defn make-ptr [] (assertf (ffi/lookup (if lazy (llib) lib) raw-symbol) "failed to find ffi symbol %v" raw-symbol)) (if lazy ~(defn ,alias ,;meta [,;formal-args] (,ffi/call (,(delay (make-ptr))) (,(delay (make-sig))) ,;formal-args)) ~(defn ,alias ,;meta [,;formal-args] (,ffi/call ,(make-ptr) ,(make-sig) ,;formal-args)))) (defmacro ffi/defbind :flycheck "Generate bindings for native functions in a convenient manner." [name ret-type & body] ~(ffi/defbind-alias ,name ,name ,ret-type ,;body))) ### ### ### Flychecking ### ### (def- flycheck-specials @{}) (defn- flycheck-evaluator `` An evaluator function that is passed to `run-context` that lints (flychecks) code for `flycheck`. This means code will be parsed, compiled, and have macros expanded, but the code will not be evaluated. `` [thunk source env where] (when (and (tuple? source) (= (tuple/type source) :parens)) (def head (source 0)) (def entry (get env head {})) (def fc (get flycheck-specials head (get entry :flycheck))) (cond # Sometimes safe form (function? fc) (fc thunk source env where) # Always safe form fc (thunk)))) (defn flycheck ``` Check a file for errors without running the file. Found errors will be printed to stderr in the usual format. Top level functions and macros that have the metadata `:flycheck` will also be evaluated during flychecking. For full control, the `:flycheck` metadata can also be a function that takes 4 arguments - `thunk`, `source`, `env`, and `where`, the same as the `:evaluator` argument to `run-context`. Other arguments to `flycheck` are the same as `dofile`. Returns nil. ``` [path &keys kwargs] (def new-env (make-env (get kwargs :env))) (put new-env *flychecking* true) (put new-env *module-cache* @{}) (put new-env *module-loading* @{}) (put new-env *module-make-env* (fn :make-flycheck-env [&] (make-env new-env))) (try (dofile path :evaluator flycheck-evaluator ;(kvs kwargs) :env new-env) ([e f] (debug/stacktrace f e ""))) nil) (defn- no-side-effects `Check if form may have side effects. If returns true, then the src must not have side effects, such as calling a C function.` [src] (cond (tuple? src) (if (= (tuple/type src) :brackets) (all no-side-effects src)) (array? src) (all no-side-effects src) (dictionary? src) (and (all no-side-effects (keys src)) (all no-side-effects (values src))) true)) (defn- is-safe-def [thunk source env where] (if-let [ve (get env (source 1)) fc (get ve :flycheck)] (cond # Sometimes safe form (function? fc) (fc thunk source env where) # Always safe form fc (thunk)) (if (no-side-effects (last source)) (thunk)))) (defn- flycheck-importer [thunk source env where] (let [[l c] (tuple/sourcemap source) newtup (tuple/setmap (tuple ;source :evaluator flycheck-evaluator) l c)] ((compile newtup env where)))) (defn- flycheck-use [thunk source env where] (each a (drop 1 source) (import* (string a) :prefix "" :evaluator flycheck-evaluator))) # Add metadata to defs and import macros for flychecking (each sym ['def 'var] (put flycheck-specials sym is-safe-def)) (each sym ['def- 'var- 'defglobal 'varglobal] (put (dyn sym) :flycheck is-safe-def)) (each sym ['import 'import* 'dofile 'require] (put (dyn sym) :flycheck flycheck-importer)) (each sym ['use] (put (dyn sym) :flycheck flycheck-use)) ### ### ### Bundle tools ### ### (compwhen (dyn 'os/stat) (def- seps {:windows "\\" :mingw "\\" :cygwin "\\"}) (defn- sep [] (get seps (os/which) "/")) (defn- bundle-rpath [path] (os/realpath path)) (defn- bundle-dir [&opt bundle-name] (def s (sep)) (string (bundle-rpath (dyn *syspath*)) s "bundle" (if bundle-name s) bundle-name)) (defn- bundle-file [bundle-name filename] (def s (sep)) (string (bundle-rpath (dyn *syspath*)) s "bundle" s bundle-name s filename)) (defn- get-manifest-filename [bundle-name] (bundle-file bundle-name "manifest.jdn")) (defn- prime-bundle-paths [] (def s (sep)) (def path (bundle-dir)) (os/mkdir path) (assert (os/stat path :mode))) (defn- get-files [manifest] (def files (get manifest :files @[])) (put manifest :files files) files) (defn- rmrf "rm -rf in janet" [x] (case (os/lstat x :mode) nil nil :directory (do (def s (sep)) (each y (os/dir x) (rmrf (string x s y))) (os/rmdir x)) (os/rm x)) nil) (defn- copyfile [from to] (if-with [ffrom (file/open from :rb)] (if-with [fto (file/open to :wb)] (do (def perm (os/stat from :permissions)) (def b (buffer/new 0x10000)) (forever (file/read ffrom 0x10000 b) (when (empty? b) (buffer/trim b) (os/chmod to perm) (break)) (file/write fto b) (buffer/clear b))) (errorf "destination file %s cannot be opened for writing" to)) (errorf "source file %s cannot be opened for reading" from))) (defn- copyrf [from to] (case (os/stat from :mode) :file (copyfile from to) :directory (do (def s (sep)) (os/mkdir to) (each y (os/dir from) (copyrf (string from s y) (string to s y))))) nil) (defn- sync-manifest [manifest] (def bn (get manifest :name)) (def manifest-name (get-manifest-filename bn)) (def b @"") (buffer/format b "%j" manifest) # make sure it is valid jdn (buffer/clear b) (buffer/format b "%.99m\n" manifest) (spit manifest-name b)) (defn bundle/manifest "Get the manifest for a given installed bundle." [bundle-name] (def name (get-manifest-filename bundle-name)) (assertf (fexists name) "no bundle %v found" bundle-name) (parse (slurp name))) (defn- get-bundle-module [bundle-name] (def manifest (bundle/manifest bundle-name)) (def dir (os/cwd)) (def workdir (get manifest :local-source ".")) (def fixed-syspath (bundle-rpath (dyn *syspath*))) (try (os/cd workdir) ([_] (print "cannot enter source directory " workdir " for bundle " bundle-name))) (defer (os/cd dir) (def new-env (make-env)) (put new-env *module-cache* @{}) (put new-env *module-loading* @{}) (put new-env *module-make-env* (fn make-bundle-env [&] (make-env new-env))) (put new-env :workdir workdir) (put new-env :name bundle-name) (put new-env *syspath* fixed-syspath) (with-env new-env (put new-env :bundle-dir (bundle-dir bundle-name)) # get the syspath right (try (require (string "@syspath/bundle/" bundle-name)) ([e f] (def pfx "could not find module @syspath/bundle/") (def msg (if (and (string? e) (string/has-prefix? pfx e)) "bundle must contain bundle.janet or bundle/init.janet" e)) (propagate msg f)))))) (defn- do-hook [module bundle-name hook & args] (def hookf (module/value module (symbol hook))) (unless hookf (break)) (def dir (os/cwd)) (os/cd (get module :workdir ".")) (defer (os/cd dir) (print "running hook " hook " for bundle " bundle-name) (hookf ;args))) (defn bundle/list "Get a list of all installed bundles in lexical order." [] (def d (bundle-dir)) (if (os/stat d :mode) (sort (os/dir d)) @[])) (defn- bundle-uninstall-unchecked [bundle-name] (def man (bundle/manifest bundle-name)) (def all-hooks (get man :hooks @[])) (when (index-of :uninstall all-hooks) (def module (get-bundle-module bundle-name)) (do-hook module bundle-name :uninstall man)) (def files (get man :files [])) (each file (reverse files) (print "remove " file) (case (os/stat file :mode) :file (os/rm file) :directory (os/rmdir file))) (rmrf (bundle-dir bundle-name)) nil) (defn bundle/uninstall ``Remove a bundle from the current syspath. There is 1 hook called during uninstallation (uninstall). A user can register a hook by defining a function with the same name in the bundle script.`` [bundle-name] (def breakage @{}) (each b (bundle/list) (unless (= b bundle-name) (def m (bundle/manifest b)) (def deps (get m :dependencies [])) (each d deps (if (= d bundle-name) (put breakage b true))))) (when (next breakage) (def breakage-list (sorted (keys breakage))) (errorf "cannot uninstall %s, breaks dependent bundles %n" bundle-name breakage-list)) (bundle-uninstall-unchecked bundle-name)) (defn bundle/topolist "Get topological order of all bundles, such that each bundle is listed after its dependencies." [] (def visited @{}) (def cycle-detect @{}) (def order @[]) (def stack @[]) (defn visit [b] (array/push stack b) (if (get visited b) (break)) (if (get cycle-detect b) (errorf "cycle detected in bundle dependencies: %s" (string/join stack " -> "))) (put cycle-detect b true) (each d (get (bundle/manifest b) :dependencies []) (visit d)) (put cycle-detect b nil) (put visited b true) (array/pop stack) (array/push order b)) (each b (bundle/list) (visit b)) order) (defn bundle/prune ``Remove all orphaned bundles from the current syspath. An orphaned bundle is a bundle that is marked for :auto-remove and is not depended on by any other bundle.`` [] (def topo (bundle/topolist)) (def rtopo (reverse topo)) # Check which auto-remove packages can be dropped # Iterate in (reverse) topological order, and if we see an auto-remove package and have not already seen # something that depends on it, then it is a root package and can be pruned. (def exempt @{}) (def to-drop @[]) (each b rtopo (def m (bundle/manifest b)) (if (or (get exempt b) (not (get m :auto-remove))) (do (put exempt b true) (each d (get m :dependencies []) (put exempt d true))) (array/push to-drop b))) (print "pruning " (length to-drop) " bundles") (each b to-drop (print "uninstall " b)) (each b to-drop (print "uninstalling " b) (bundle-uninstall-unchecked b))) (defn bundle/installed? "Check if a bundle is installed." [bundle-name] (not (not (os/stat (bundle-dir bundle-name) :mode)))) (defn bundle/install ``Install a bundle from the local filesystem. The name of the bundle is the value mapped to :name in either `config` or the info file. There are 5 hooks called during installation (postdeps, clean, build, install and check). A user can register a hook by defining a function with the same name in the bundle script.`` [path &keys config] (def path (bundle-rpath path)) (def s (sep)) # Detect bundle name (def infofile-src1 (string path s "bundle" s "info.jdn")) (def infofile-src2 (string path s "info.jdn")) (def infofile-src (cond (fexists infofile-src1) infofile-src1 (fexists infofile-src2) infofile-src2)) (def info (-?> infofile-src slurp parse)) (def bundle-name (get config :name (get info :name))) (assertf bundle-name "unable to infer bundle name for %v, use :name argument or add :name to info file" path) (assertf (not (string/check-set "\\/" bundle-name)) "bundle name %v cannot contain path separators" bundle-name) (assert (next bundle-name) "cannot use empty bundle-name") (assertf (not (fexists (get-manifest-filename bundle-name))) "bundle %v is already installed" bundle-name) # Check bscript (def bscript-src1 (string path s "bundle" s "init.janet")) (def bscript-src2 (string path s "bundle.janet")) (def bscript-src (cond (fexists bscript-src1) bscript-src1 (fexists bscript-src2) bscript-src2)) # Setup installed paths (prime-bundle-paths) (os/mkdir (bundle-dir bundle-name)) # Copy aliased infofile (when (fexists infofile-src2) (copyfile infofile-src2 (bundle-file bundle-name "info.jdn"))) # Copy aliased bscript (when (fexists bscript-src2) (copyfile bscript-src2 (bundle-file bundle-name "init.janet"))) # Copy some files into the new location unconditionally (def implicit-sources (string path s "bundle")) (when (= :directory (os/stat implicit-sources :mode)) (copyrf implicit-sources (bundle-dir bundle-name))) (def man @{:name bundle-name :local-source path :files @[]}) (merge-into man config) (sync-manifest man) (edefer (do (print "installation error, uninstalling") (bundle/uninstall bundle-name)) (when info (def deps (seq [d :in (get info :dependencies @[])] (string (if (dictionary? d) (get d :name) d)))) (def missing (filter (complement bundle/installed?) deps)) (when (next missing) (error (string "missing dependencies " (string/join missing ", ")))) (put man :dependencies deps) (put man :info info)) (def module (get-bundle-module bundle-name)) (def clean (get config :clean)) (def check (get config :check)) (def all-hooks (seq [[k v] :pairs module :when (symbol? k) :unless (get v :private)] (keyword k))) (put man :hooks all-hooks) (do-hook module bundle-name :dependencies man) # deprecated, use :postdeps (do-hook module bundle-name :postdeps man) (when clean (do-hook module bundle-name :clean man)) (do-hook module bundle-name :build man) (do-hook module bundle-name :install man) (if (empty? (get man :files)) (print "no files installed, is this a valid bundle?")) (sync-manifest man) (when check (do-hook module bundle-name :check man))) (print "installed " bundle-name) (when (or (get man :has-exe) # remove eventually (get man :has-bin-script)) (def binpath (string (dyn *syspath*) s "bin")) (eprintf "executable files have been installed to %s" binpath)) (when (get man :has-man) (def manpath (string (dyn *syspath*) s "man")) (eprintf "man pages have been installed to %s" manpath)) bundle-name) (defn- bundle/pack ``Take an installed bundle and create a bundle source directory that can be used to reinstall the bundle on a compatible system. This is used to create backups for installed bundles without rebuilding, or make a prebuilt bundle for other systems.`` [bundle-name dest-dir &opt is-backup] (var i 0) (def man (bundle/manifest bundle-name)) (def files (get man :files @[])) (assertf (os/mkdir dest-dir) "could not create directory %v (or it already exists)" dest-dir) (def s (sep)) (os/mkdir (string dest-dir s "bundle")) (def install-hook (string dest-dir s "bundle" s "init.janet")) (edefer (rmrf dest-dir) # don't leave garbage on failure (def install-source @[]) (def syspath (bundle-rpath (dyn *syspath*))) (when is-backup (copyrf (bundle-dir bundle-name) (string dest-dir s "old-bundle"))) (each file files (def {:mode mode :permissions perm} (os/stat file)) (def relpath (string/triml (slice file (length syspath) -1) s)) (case mode :directory (array/push install-source ~(bundle/add-directory manifest ,relpath ,perm)) :file (do (def filename (string/format "file_%06d" (++ i))) (copyfile file (string dest-dir s filename)) (array/push install-source ~(bundle/add-file manifest ,filename ,relpath ,perm))) (errorf "unexpected file %v" file))) (def b @"(defn install [manifest]") (each form install-source (buffer/format b "\n %j" form)) (buffer/push b ")\n") (spit install-hook b)) dest-dir) (defn bundle/replace ``Reinstall an existing bundle from a new directory. Similar to bundle/reinstall, but installs the replacement bundle from any directory. This is necessary to replace a package without breaking any dependencies.`` [bundle-name path &keys new-config] (def manifest (bundle/manifest bundle-name)) (def config (get manifest :config @{})) (def s (sep)) (assertf (= :directory (os/stat path :mode)) "local source %v not available" path) (def backup-dir (string (dyn *syspath*) s bundle-name ".backup")) (rmrf backup-dir) (def backup-bundle-source (bundle/pack bundle-name backup-dir true)) (edefer (do (bundle/install backup-bundle-source :name bundle-name) (copyrf (string backup-bundle-source s "old-bundle") (bundle-dir bundle-name)) (rmrf backup-bundle-source)) (bundle-uninstall-unchecked bundle-name) (bundle/install path :name bundle-name ;(kvs config) ;(kvs new-config))) (rmrf backup-bundle-source) bundle-name) (defn bundle/reinstall "Reinstall an existing bundle from the local source code." [bundle-name &keys new-config] (def manifest (bundle/manifest bundle-name)) (def path (get manifest :local-source)) (bundle/replace bundle-name path ;(kvs new-config)) bundle-name) (defn bundle/add-directory "Add a directory during an install relative to `(dyn *syspath*)`." [manifest dest &opt chmod-mode] (def files (get-files manifest)) (def s (sep)) (def absdest (string (dyn *syspath*) s dest)) (unless (os/mkdir absdest) (errorf "collision at %s, directory already exists" absdest)) (def absdest (os/realpath absdest)) (array/push files absdest) (when chmod-mode (os/chmod absdest chmod-mode)) (print "add " absdest) absdest) (defn bundle/whois "Given a file path, figure out which bundle installed it." [path] (var ret nil) (def rpath (bundle-rpath path)) (each bundle-name (bundle/list) (def files (get (bundle/manifest bundle-name) :files [])) (def has-file (index-of rpath files)) (when has-file (set ret bundle-name) (break))) ret) (defn bundle/add-file "Add a file during an install relative to `(dyn *syspath*)`." [manifest src &opt dest chmod-mode] (default dest src) (def files (get-files manifest)) (def s (sep)) (def absdest (string (dyn *syspath*) s dest)) (when (os/stat absdest :mode) (errorf "collision at %s, file already exists" absdest)) (copyfile src absdest) (def absdest (os/realpath absdest)) (array/push files absdest) (when chmod-mode (os/chmod absdest chmod-mode)) (print "add " absdest) absdest) (defn bundle/add ``Add a file or directory during an install relative to `(dyn *syspath*)`. Added files and directories will be recorded in the bundle manifest such that they are properly tracked and removed during an upgrade or uninstall.`` [manifest src &opt dest chmod-mode] (default dest src) (def s (sep)) (def mode (os/stat src :mode)) (if-not mode (errorf "file %s does not exist" src)) (case mode :directory (let [absdest (bundle/add-directory manifest dest chmod-mode)] (each d (os/dir src) (bundle/add manifest (string src s d) (string dest s d) chmod-mode)) absdest) :file (bundle/add-file manifest src dest chmod-mode) (errorf "bad path %s - file is a %s" src mode))) (defn bundle/add-bin ``Add a file to the "bin" subdirectory of the current syspath. By default, files will be set to be executable.`` [manifest src &opt filename chmod-mode] (def s (sep)) (default filename (last (string/split s src))) (default chmod-mode 8r755) (os/mkdir (string (dyn *syspath*) s "bin")) (put manifest :has-exe true) (put manifest :has-bin-script true) # remove eventually (bundle/add-file manifest src (string "bin" s filename) chmod-mode)) (defn bundle/add-manpage ``Add a file to the man subdirectory of the current syspath. Files are copied inside a directory `mansec`. By default, `mansec` is "man1".`` [manifest src &opt mansec] (def s (sep)) (default mansec "man1") (def filename (last (string/split s src))) (os/mkdir (string (dyn *syspath*) s "man")) (os/mkdir (string (dyn *syspath*) s "man" s mansec)) (put manifest :has-man true) (bundle/add-file manifest src (string "man" s mansec s filename))) (defn bundle/update-all "Reinstall all bundles." [&keys configs] (each bundle (bundle/topolist) (bundle/reinstall bundle ;(kvs configs))))) ### ### ### CLI Tool Main ### ### # conditional compilation for reduced os (def- getenv-raw (if-let [entry (in root-env 'os/getenv)] (entry :value) (fn [&]))) (defn- getenv-alias [env-var &opt dflt] (def x (getenv-raw env-var dflt)) (if (= x "") nil x)) # empty string is coerced to nil (defn- run-main [env subargs arg] (when-let [entry (in env 'main) main (or (get entry :value) (in (get entry :ref) 0))] (def guard (if (get env :debug) :ydt :y)) (defn wrap-main [&] (main ;subargs)) (def f (fiber/new wrap-main guard env)) (var res nil) (while (fiber/can-resume? f) (set res (resume f res)) (when (not= :dead (fiber/status f)) ((debugger-on-status env) f res))))) (defdyn *args* "Dynamic bindings that will contain command line arguments at program start.") (defdyn *executable* ``Name of the interpreter executable used to execute this program. Corresponds to `argv[0]` in the call to `int main(int argc, char **argv);`.``) (defdyn *profilepath* "Path to profile file loaded when starting up the repl.") (compwhen (not (dyn 'os/isatty)) (defmacro os/isatty [&] true)) (def- long-to-short "map long options to short options" {"-help" "h" "-version" "v" "-stdin" "s" "-eval" "e" "-expression" "E" "-debug" "d" "-repl" "r" "-noprofile" "R" "-persistent" "p" "-quiet" "q" "-flycheck" "k" "-syspath" "m" "-compile" "c" "-image" "i" "-nocolor" "n" "-color" "N" "-library" "l" "-install" "b" "-reinstall" "B" "-uninstall" "u" "-update-all" "U" "-list" "L" "-prune" "P" "-lint-warn" "w" "-lint-error" "x"}) (defn- apply-color [colorize] (setdyn *pretty-format* (if colorize "%.20Q" "%.20q")) (setdyn *err-color* (if colorize true)) (setdyn *doc-color* (if colorize true))) (defn- getstdin [prompt buf _] (file/write stdout prompt) (file/flush stdout) (file/read stdin :line buf)) (defn cli-main `Entrance for the Janet CLI tool. Call this function with the command line arguments as an array or tuple of strings to invoke the CLI interface.` [args] (setdyn *args* args) (var should-repl nil) (var no-file true) (var quiet false) (var raw-stdin false) (var handleopts true) (var exit-on-error true) (var compile-only false) (var expect-image false) (when-let [jp (getenv-alias "JANET_PATH")] (def path-sep (if (index-of (os/which) [:windows :mingw]) ";" ":")) (def paths (reverse! (string/split path-sep jp))) (for i 1 (length paths) (module/add-syspath (get paths i))) (setdyn *syspath* (first paths))) (if-let [jprofile (getenv-alias "JANET_PROFILE")] (setdyn *profilepath* jprofile)) (apply-color (and (not (getenv-alias "NO_COLOR")) (os/isatty stdout))) (defn- get-lint-level [i] (def x (in args (+ i 1))) (or (scan-number x) (keyword x))) # Flag handlers (def handlers {"h" (fn [&] (print "usage: " (dyn *executable* "janet") " [options] script args...") (print ``` Options are: --help (-h) : Show this help --version (-v) : Print the version string --stdin (-s) : Use raw stdin instead of getline like functionality --eval (-e) code : Execute a string of janet --expression (-E) code arguments... : Evaluate an expression as a short-fn with arguments --debug (-d) : Set the debug flag in the REPL --repl (-r) : Enter the REPL after running all scripts --noprofile (-R) : Disables loading profile.janet when JANET_PROFILE is present --persistent (-p) : Keep on executing if there is a top-level error (persistent) --quiet (-q) : Hide logo (quiet) --flycheck (-k) : Compile scripts but do not execute (flycheck) --syspath (-m) syspath : Set system path for loading global modules --compile (-c) source output : Compile janet source code into an image --image (-i) : Load the script argument as an image file instead of source code --nocolor (-n) : Disable ANSI color output in the REPL --color (-N) : Enable ANSI color output in the REPL --library (-l) lib : Use a module before processing more arguments --lint-warn (-w) level : Set the lint warning level - default is "normal" --lint-error (-x) level : Set the lint error level - default is "none" --install (-b) dirpath : Install a bundle from a directory --reinstall (-B) name : Reinstall a bundle by bundle name --uninstall (-u) name : Uninstall a bundle by bundle name --update-all (-U) : Reinstall all installed bundles --prune (-P) : Uninstall all bundles that are orphaned --list (-L) : List all installed bundles -- : Stop handling options ```) (os/exit 0) 1) "v" (fn [&] (print janet/version "-" janet/build) (os/exit 0) 1) "s" (fn [&] (set raw-stdin true) (set should-repl true) 1) "r" (fn [&] (set should-repl true) 1) "p" (fn [&] (set exit-on-error false) 1) "q" (fn [&] (set quiet true) 1) "i" (fn [&] (set expect-image true) 1) "k" (fn [&] (set compile-only true) (set exit-on-error false) 1) "n" (fn [&] (apply-color false) 1) "N" (fn [&] (apply-color true) 1) "m" (fn [i &] (setdyn *syspath* (in args (+ i 1))) 2) "c" (fn c-switch [i &] (def path (in args (+ i 1))) (def e (dofile path)) (def output-path (if (< (+ i 2) (length args)) (in args (+ i 2)) (string (if (string/has-suffix? ".janet" path) (string/slice path 0 -7) path) ".jimage"))) (spit output-path (make-image e)) (set no-file false) 3) "-" (fn [&] (set handleopts false) 1) "l" (fn l-switch [i &] (import* (in args (+ i 1)) :prefix "" :exit exit-on-error) 2) "e" (fn e-switch [i &] (set no-file false) (eval-string (in args (+ i 1))) 2) "E" (fn E-switch [i &] (set no-file false) (def subargs (array/slice args (+ i 2))) (def src ~(short-fn ,(parse (in args (+ i 1))) E-expression)) (def thunk (compile src)) (if (function? thunk) ((thunk) ;subargs) (error (get thunk :error))) math/inf) "b" (compif (dyn 'bundle/install) (fn [i &] (bundle/install (in args (+ i 1))) (set no-file false) (if (= nil should-repl) (set should-repl false)) 2) (fn [i &] (eprint "--install not supported with reduced os") 2)) "B" (compif (dyn 'bundle/reinstall) (fn [i &] (bundle/reinstall (in args (+ i 1))) (set no-file false) (if (= nil should-repl) (set should-repl false)) 2) (fn [i &] (eprint "--reinstall not supported with reduced os") 2)) "u" (compif (dyn 'bundle/uninstall) (fn [i &] (bundle/uninstall (in args (+ i 1))) (set no-file false) (if (= nil should-repl) (set should-repl false)) 2) (fn [i &] (eprint "--uninstall not supported with reduced os") 2)) "P" (compif (dyn 'bundle/prune) (fn [i &] (bundle/prune) (set no-file false) (if (= nil should-repl) (set should-repl false)) 1) (fn [i &] (eprint "--prune not supported with reduced os") 1)) "U" (compif (dyn 'bundle/update-all) (fn [i &] (bundle/update-all) (set no-file false) (if (= nil should-repl) (set should-repl false)) 1) (fn [i &] (eprint "--update-all not supported with reduced os") 1)) "L" (compif (dyn 'bundle/list) (fn [i &] (each l (bundle/list) (print l)) (set no-file false) (if (= nil should-repl) (set should-repl false)) 1) (fn [i &] (eprint "--list not supported with reduced os") 1)) "d" (fn [&] (setdyn *debug* true) (setdyn *redef* true) 1) "w" (fn [i &] (setdyn *lint-warn* (get-lint-level i)) 2) "x" (fn [i &] (setdyn *lint-error* (get-lint-level i)) 2) "R" (fn [&] (setdyn *profilepath* nil) 1)}) (defn- dohandler [n i &] (def h (in handlers (get long-to-short n n))) (if h (h i handlers) (do (print "unknown flag -" n) ((in handlers "h"))))) # Process arguments (var i 0) (def lenargs (length args)) (while (< i lenargs) (def arg (in args i)) (if (and handleopts (= "-" (string/slice arg 0 1))) (+= i (dohandler (string/slice arg 1) i)) (do (def subargs (array/slice args i)) (set no-file false) (if expect-image (do (def env (load-image (slurp arg))) (put env *args* subargs) (run-main env subargs arg)) (do (def env (make-env)) (put env *args* subargs) (if compile-only (flycheck arg :exit exit-on-error :env env) (do (dofile arg :exit exit-on-error :env env) (run-main env subargs arg))))) (set i lenargs)))) (if (or should-repl no-file) (if compile-only (flycheck stdin :source :stdin :exit exit-on-error) (do (if-not quiet (print "Janet " janet/version "-" janet/build " " (os/which) "/" (os/arch) "/" (os/compiler) " - '(doc)' for help")) (flush) (def env (make-env)) (defn getprompt [p] (when-let [custom-prompt (get env *repl-prompt*)] (break (custom-prompt p))) (def [line] (parser/where p)) (string "repl:" line ":" (parser/state p :delimiters) "> ")) (def getter (if raw-stdin getstdin getline)) (defn getchunk [buf p] (getter (getprompt p) buf env)) (when-let [profile.janet (dyn *profilepath*)] (dofile profile.janet :exit true :env env) (put env *current-file* nil)) (repl getchunk nil env))))) ### ### ### Bootstrap ### ### (do # Modify root-env to remove private symbols and # flatten nested tables. (loop [[k v] :in (pairs root-env) :when (symbol? k)] (def flat (table/proto-flatten v)) (when (boot/config :no-docstrings) (put flat :doc nil)) (when (boot/config :no-sourcemaps) (put flat :source-map nil)) (unless (boot/config :no-docstrings) (unless (v :private) (unless (v :doc) (errorf "no docs: %v %p" k v)))) # make sure we have docs # Fix directory separators on windows to make image identical between windows and non-windows (when-let [sm (get flat :source-map)] (put flat :source-map [(string/replace-all "\\" "/" (sm 0)) (sm 1) (sm 2)])) (if (v :private) (put root-env k nil) (put root-env k flat))) (put root-env 'boot/config nil) (put root-env 'boot/args nil) # Build dictionary for loading images (def load-dict (env-lookup root-env)) (each [k v] (pairs load-dict) (if (number? v) (put load-dict k nil))) (merge-into load-image-dict load-dict) (def image (let [env-pairs (pairs (env-lookup root-env)) essential-pairs (filter (fn [[k v]] (or (cfunction? v) (abstract? v))) env-pairs) lookup (table ;(mapcat identity essential-pairs)) reverse-lookup (invert lookup)] # Check no duplicate values (def temp @{}) (eachp [k v] lookup (if (in temp v) (errorf "duplicate value: %v" v)) (put temp v k)) (marshal root-env reverse-lookup))) # Create amalgamation (def feature-header "src/core/features.h") (def local-headers ["src/core/state.h" "src/core/util.h" "src/core/gc.h" "src/core/vector.h" "src/core/fiber.h" "src/core/regalloc.h" "src/core/compile.h" "src/core/emit.h" "src/core/symcache.h"]) (def core-sources ["src/core/abstract.c" "src/core/array.c" "src/core/asm.c" "src/core/buffer.c" "src/core/bytecode.c" "src/core/capi.c" "src/core/cfuns.c" "src/core/compile.c" "src/core/corelib.c" "src/core/debug.c" "src/core/emit.c" "src/core/ev.c" "src/core/ffi.c" "src/core/fiber.c" "src/core/filewatch.c" "src/core/gc.c" "src/core/inttypes.c" "src/core/io.c" "src/core/marsh.c" "src/core/math.c" "src/core/net.c" "src/core/os.c" "src/core/parse.c" "src/core/peg.c" "src/core/pp.c" "src/core/regalloc.c" "src/core/run.c" "src/core/specials.c" "src/core/state.c" "src/core/string.c" "src/core/strtod.c" "src/core/struct.c" "src/core/symcache.c" "src/core/table.c" "src/core/tuple.c" "src/core/util.c" "src/core/value.c" "src/core/vector.c" "src/core/vm.c" "src/core/wrap.c"]) # Print janet.c to stdout (def image-only (has-value? boot/args "image-only")) (print "/* " (if image-only "Image-only" "Amalgamated") " build - DO NOT EDIT */") (print "/* Generated from janet version " janet/version "-" janet/build " */") (print "#define JANET_BUILD \"" janet/build "\"") (print ```#define JANET_AMALG```) (defn do-one-file [fname] (unless image-only (print "\n/* " fname " */") (print "#line 0 \"" fname "\"\n") (def source (slurp fname)) (print (string/replace-all "\r" "" source)))) (do-one-file feature-header) (print ```#include "janet.h"```) (each h local-headers (do-one-file h)) # windows.h should not be included in any of the external or internal headers - only in .c files. (print) (print "/* Windows work around - winsock2 must be included before windows.h, especially in amalgamated build */") (print "#if defined(JANET_WINDOWS) && defined(JANET_NET)") (print "#include ") (print "#endif") (print) (each s core-sources (do-one-file s)) # Create C source file that contains the boot image in a uint8_t buffer. This # can be compiled and linked statically into the main janet library and client (print "static const unsigned char janet_core_image_bytes[] = {") (loop [line :in (partition 16 image)] (prin " ") (each b line (prinf "0x%.2X, " b)) (print)) (print " 0\n};\n") (print "const unsigned char *janet_core_image = janet_core_image_bytes;") (print "size_t janet_core_image_size = sizeof(janet_core_image_bytes);")) janet-1.41.2/src/boot/buffer_test.c000066400000000000000000000042021514534607600171170ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #include #include #include "tests.h" int buffer_test() { int i; JanetBuffer *buffer1, *buffer2; buffer1 = janet_buffer(100); buffer2 = janet_buffer(0); janet_buffer_push_cstring(buffer1, "hello, world!\n"); janet_buffer_push_u8(buffer2, 'h'); janet_buffer_push_u8(buffer2, 'e'); janet_buffer_push_u8(buffer2, 'l'); janet_buffer_push_u8(buffer2, 'l'); janet_buffer_push_u8(buffer2, 'o'); janet_buffer_push_u8(buffer2, ','); janet_buffer_push_u8(buffer2, ' '); janet_buffer_push_u8(buffer2, 'w'); janet_buffer_push_u8(buffer2, 'o'); janet_buffer_push_u8(buffer2, 'r'); janet_buffer_push_u8(buffer2, 'l'); janet_buffer_push_u8(buffer2, 'd'); janet_buffer_push_u8(buffer2, '!'); janet_buffer_push_u8(buffer2, '\n'); assert(buffer1->count == buffer2->count); assert(buffer1->capacity >= buffer1->count); assert(buffer2->capacity >= buffer2->count); for (i = 0; i < buffer1->count; i++) { assert(buffer1->data[i] == buffer2->data[i]); } return 0; } janet-1.41.2/src/boot/number_test.c000066400000000000000000000045521514534607600171460ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #include #include #include #include #include "tests.h" /* Check a subset of numbers against system implementation. * Note that this depends on the system implementation being correct, * which may not be the case for old or non compliant systems. Also, * we cannot check against bases other 10. */ /* Compare valid c numbers to system implementation. */ static void test_valid_str(const char *str) { int err; double cnum, jnum; jnum = 0.0; cnum = atof(str); err = janet_scan_number((const uint8_t *) str, (int32_t) strlen(str), &jnum); assert(!err); assert(cnum == jnum); } int number_test() { #ifdef JANET_PLAN9 return 0; #endif test_valid_str("1.0"); test_valid_str("1"); test_valid_str("2.1"); test_valid_str("1e10"); test_valid_str("2e10"); test_valid_str("1e-10"); test_valid_str("2e-10"); test_valid_str("1.123123e10"); test_valid_str("1.123123e-10"); test_valid_str("-1.23e2"); test_valid_str("-4.5e15"); test_valid_str("-4.5e151"); test_valid_str("-4.5e200"); test_valid_str("-4.5e123"); test_valid_str("123123123123123123132123"); test_valid_str("0000000011111111111111111111111111"); test_valid_str(".112312333333323123123123123123123"); return 0; } janet-1.41.2/src/boot/system_test.c000066400000000000000000000062451514534607600172030ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #include #include #include #include #include "tests.h" int system_test() { #ifdef JANET_32 assert(sizeof(void *) == 4); #else assert(sizeof(void *) == 8); #endif /* Check the version defines are self consistent */ char version_combined[256]; snprintf(version_combined, sizeof(version_combined), "%d.%d.%d%s", JANET_VERSION_MAJOR, JANET_VERSION_MINOR, JANET_VERSION_PATCH, JANET_VERSION_EXTRA); assert(!strcmp(JANET_VERSION, version_combined)); /* Reflexive testing and nanbox testing */ assert(janet_equals(janet_wrap_nil(), janet_wrap_nil())); assert(janet_equals(janet_wrap_false(), janet_wrap_false())); assert(janet_equals(janet_wrap_true(), janet_wrap_true())); assert(janet_equals(janet_wrap_integer(1), janet_wrap_integer(1))); assert(janet_equals(janet_wrap_integer(INT32_MAX), janet_wrap_integer(INT32_MAX))); assert(janet_equals(janet_wrap_integer(-2), janet_wrap_integer(-2))); assert(janet_equals(janet_wrap_integer(INT32_MIN), janet_wrap_integer(INT32_MIN))); assert(janet_equals(janet_wrap_number(1.4), janet_wrap_number(1.4))); assert(janet_equals(janet_wrap_number(3.14159265), janet_wrap_number(3.14159265))); #ifdef NAN #ifdef JANET_PLAN9 // Plan 9 traps NaNs by default; disable that. setfcr(0); #endif assert(janet_checktype(janet_wrap_number(NAN), JANET_NUMBER)); #else assert(janet_checktype(janet_wrap_number(0.0 / 0.0), JANET_NUMBER)); #endif assert(NULL != &janet_wrap_nil); assert(janet_equals(janet_cstringv("a string."), janet_cstringv("a string."))); assert(janet_equals(janet_csymbolv("sym"), janet_csymbolv("sym"))); Janet *t1 = janet_tuple_begin(3); t1[0] = janet_wrap_nil(); t1[1] = janet_wrap_integer(4); t1[2] = janet_cstringv("hi"); Janet tuple1 = janet_wrap_tuple(janet_tuple_end(t1)); Janet *t2 = janet_tuple_begin(3); t2[0] = janet_wrap_nil(); t2[1] = janet_wrap_integer(4); t2[2] = janet_cstringv("hi"); Janet tuple2 = janet_wrap_tuple(janet_tuple_end(t2)); assert(janet_equals(tuple1, tuple2)); return 0; } janet-1.41.2/src/boot/table_test.c000066400000000000000000000060731514534607600167450ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #include #include #include "tests.h" int table_test() { JanetTable *t1, *t2; t1 = janet_table(10); t2 = janet_table(0); janet_table_put(t1, janet_cstringv("hello"), janet_wrap_integer(2)); janet_table_put(t1, janet_cstringv("akey"), janet_wrap_integer(5)); janet_table_put(t1, janet_cstringv("box"), janet_wrap_boolean(0)); janet_table_put(t1, janet_cstringv("square"), janet_cstringv("avalue")); assert(t1->count == 4); assert(t1->capacity >= t1->count); assert(janet_equals(janet_table_get(t1, janet_cstringv("hello")), janet_wrap_integer(2))); assert(janet_equals(janet_table_get(t1, janet_cstringv("akey")), janet_wrap_integer(5))); assert(janet_equals(janet_table_get(t1, janet_cstringv("box")), janet_wrap_boolean(0))); assert(janet_equals(janet_table_get(t1, janet_cstringv("square")), janet_cstringv("avalue"))); janet_table_remove(t1, janet_cstringv("hello")); janet_table_put(t1, janet_cstringv("box"), janet_wrap_nil()); assert(t1->count == 2); assert(janet_equals(janet_table_get(t1, janet_cstringv("hello")), janet_wrap_nil())); assert(janet_equals(janet_table_get(t1, janet_cstringv("box")), janet_wrap_nil())); janet_table_put(t2, janet_csymbolv("t2key1"), janet_wrap_integer(10)); janet_table_put(t2, janet_csymbolv("t2key2"), janet_wrap_integer(100)); janet_table_put(t2, janet_csymbolv("some key "), janet_wrap_integer(-2)); janet_table_put(t2, janet_csymbolv("a thing"), janet_wrap_integer(10)); assert(janet_equals(janet_table_get(t2, janet_csymbolv("t2key1")), janet_wrap_integer(10))); assert(janet_equals(janet_table_get(t2, janet_csymbolv("t2key2")), janet_wrap_integer(100))); assert(t2->count == 4); assert(janet_equals(janet_table_remove(t2, janet_csymbolv("t2key1")), janet_wrap_integer(10))); assert(t2->count == 3); assert(janet_equals(janet_table_remove(t2, janet_csymbolv("t2key2")), janet_wrap_integer(100))); assert(t2->count == 2); return 0; } janet-1.41.2/src/boot/tests.h000066400000000000000000000003641514534607600157630ustar00rootroot00000000000000#ifndef TESTS_H_DNMBUYYL #define TESTS_H_DNMBUYYL /* Tests */ extern int array_test(); extern int buffer_test(); extern int number_test(); extern int system_test(); extern int table_test(); #endif /* end of include guard: TESTS_H_DNMBUYYL */ janet-1.41.2/src/conf/000077500000000000000000000000001514534607600144275ustar00rootroot00000000000000janet-1.41.2/src/conf/janetconf.h000066400000000000000000000046761514534607600165640ustar00rootroot00000000000000/* This will be generated by the build system if this file is not used */ #ifndef JANETCONF_H #define JANETCONF_H #define JANET_VERSION_MAJOR 1 #define JANET_VERSION_MINOR 41 #define JANET_VERSION_PATCH 2 #define JANET_VERSION_EXTRA "" #define JANET_VERSION "1.41.2" /* #define JANET_BUILD "local" */ /* These settings all affect linking, so use cautiously. */ /* #define JANET_SINGLE_THREADED */ /* #define JANET_THREAD_LOCAL _Thread_local */ /* #define JANET_NO_DYNAMIC_MODULES */ /* #define JANET_NO_NANBOX */ /* #define JANET_API __attribute__((visibility ("default"))) */ /* These settings should be specified before amalgamation is * built. Any build with these set should be considered non-standard, and * certain Janet libraries should be expected not to work. */ /* #define JANET_NO_DOCSTRINGS */ /* #define JANET_NO_SOURCEMAPS */ /* #define JANET_REDUCED_OS */ /* #define JANET_NO_PROCESSES */ /* #define JANET_NO_ASSEMBLER */ /* #define JANET_NO_PEG */ /* #define JANET_NO_NET */ /* #define JANET_NO_INT_TYPES */ /* #define JANET_NO_EV */ /* #define JANET_NO_FILEWATCH */ /* #define JANET_NO_REALPATH */ /* #define JANET_NO_SYMLINKS */ /* #define JANET_NO_UMASK */ /* #define JANET_NO_THREADS */ /* #define JANET_NO_FFI */ /* #define JANET_NO_FFI_JIT */ /* Other settings */ /* #define JANET_DEBUG */ /* #define JANET_PRF */ /* #define JANET_NO_UTC_MKTIME */ /* #define JANET_OUT_OF_MEMORY do { printf("janet out of memory\n"); exit(1); } while (0) */ /* #define JANET_EXIT(msg) do { printf("C assert failed executing janet: %s\n", msg); exit(1); } while (0) */ /* #define JANET_TOP_LEVEL_SIGNAL(msg) call_my_function((msg), stderr) */ /* #define JANET_RECURSION_GUARD 1024 */ /* #define JANET_MAX_PROTO_DEPTH 200 */ /* #define JANET_MAX_MACRO_EXPAND 200 */ /* #define JANET_STACK_MAX 16384 */ /* #define JANET_OS_NAME my-custom-os */ /* #define JANET_ARCH_NAME pdp-8 */ /* #define JANET_EV_NO_EPOLL */ /* #define JANET_EV_NO_KQUEUE */ /* #define JANET_NO_INTERPRETER_INTERRUPT */ /* #define JANET_NO_IPV6 */ /* #define JANET_NO_CRYPTORAND */ /* #define JANET_USE_STDATOMIC */ /* Custom vm allocator support */ /* #include */ /* #define janet_malloc(X) mi_malloc((X)) */ /* #define janet_realloc(X, Y) mi_realloc((X), (Y)) */ /* #define janet_calloc(X, Y) mi_calloc((X), (Y)) */ /* #define janet_free(X) mi_free((X)) */ /* Main client settings, does not affect library code */ /* #define JANET_SIMPLE_GETLINE */ #endif /* end of include guard: JANETCONF_H */ janet-1.41.2/src/core/000077500000000000000000000000001514534607600144325ustar00rootroot00000000000000janet-1.41.2/src/core/abstract.c000066400000000000000000000142531514534607600164060ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "util.h" #include "gc.h" #include "state.h" #endif #ifdef JANET_EV #ifdef JANET_WINDOWS #include #endif #endif /* Create new userdata */ void *janet_abstract_begin(const JanetAbstractType *atype, size_t size) { JanetAbstractHead *header = janet_gcalloc(JANET_MEMORY_NONE, sizeof(JanetAbstractHead) + size); header->size = size; header->type = atype; return (void *) & (header->data); } void *janet_abstract_end(void *x) { janet_gc_settype((void *)(janet_abstract_head(x)), JANET_MEMORY_ABSTRACT); return x; } void *janet_abstract(const JanetAbstractType *atype, size_t size) { return janet_abstract_end(janet_abstract_begin(atype, size)); } #ifdef JANET_EV /* * Threaded abstracts */ void *janet_abstract_begin_threaded(const JanetAbstractType *atype, size_t size) { JanetAbstractHead *header = janet_malloc(sizeof(JanetAbstractHead) + size); if (NULL == header) { JANET_OUT_OF_MEMORY; } janet_vm.next_collection += size + sizeof(JanetAbstractHead); header->gc.flags = JANET_MEMORY_THREADED_ABSTRACT; header->gc.data.next = NULL; /* Clear memory for address sanitizers */ header->gc.data.refcount = 1; header->size = size; header->type = atype; void *abstract = (void *) & (header->data); janet_table_put(&janet_vm.threaded_abstracts, janet_wrap_abstract(abstract), janet_wrap_false()); return abstract; } void *janet_abstract_end_threaded(void *x) { janet_gc_settype((void *)(janet_abstract_head(x)), JANET_MEMORY_THREADED_ABSTRACT); return x; } void *janet_abstract_threaded(const JanetAbstractType *atype, size_t size) { return janet_abstract_end_threaded(janet_abstract_begin_threaded(atype, size)); } /* Refcounting primitives and sync primitives */ #ifdef JANET_WINDOWS size_t janet_os_mutex_size(void) { return sizeof(CRITICAL_SECTION); } size_t janet_os_rwlock_size(void) { return sizeof(void *); } void janet_os_mutex_init(JanetOSMutex *mutex) { InitializeCriticalSection((CRITICAL_SECTION *) mutex); } void janet_os_mutex_deinit(JanetOSMutex *mutex) { DeleteCriticalSection((CRITICAL_SECTION *) mutex); } void janet_os_mutex_lock(JanetOSMutex *mutex) { EnterCriticalSection((CRITICAL_SECTION *) mutex); } void janet_os_mutex_unlock(JanetOSMutex *mutex) { /* error handling? May want to keep counter */ LeaveCriticalSection((CRITICAL_SECTION *) mutex); } void janet_os_rwlock_init(JanetOSRWLock *rwlock) { InitializeSRWLock((PSRWLOCK) rwlock); } void janet_os_rwlock_deinit(JanetOSRWLock *rwlock) { /* no op? */ (void) rwlock; } void janet_os_rwlock_rlock(JanetOSRWLock *rwlock) { AcquireSRWLockShared((PSRWLOCK) rwlock); } void janet_os_rwlock_wlock(JanetOSRWLock *rwlock) { AcquireSRWLockExclusive((PSRWLOCK) rwlock); } void janet_os_rwlock_runlock(JanetOSRWLock *rwlock) { ReleaseSRWLockShared((PSRWLOCK) rwlock); } void janet_os_rwlock_wunlock(JanetOSRWLock *rwlock) { ReleaseSRWLockExclusive((PSRWLOCK) rwlock); } #else size_t janet_os_mutex_size(void) { return sizeof(pthread_mutex_t); } size_t janet_os_rwlock_size(void) { return sizeof(pthread_rwlock_t); } void janet_os_mutex_init(JanetOSMutex *mutex) { pthread_mutexattr_t attr; pthread_mutexattr_init(&attr); pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE); pthread_mutex_init((pthread_mutex_t *) mutex, &attr); } void janet_os_mutex_deinit(JanetOSMutex *mutex) { pthread_mutex_destroy((pthread_mutex_t *) mutex); } void janet_os_mutex_lock(JanetOSMutex *mutex) { pthread_mutex_lock((pthread_mutex_t *) mutex); } void janet_os_mutex_unlock(JanetOSMutex *mutex) { int ret = pthread_mutex_unlock((pthread_mutex_t *) mutex); if (ret) janet_panic("cannot release lock"); } void janet_os_rwlock_init(JanetOSRWLock *rwlock) { pthread_rwlock_init((pthread_rwlock_t *) rwlock, NULL); } void janet_os_rwlock_deinit(JanetOSRWLock *rwlock) { pthread_rwlock_destroy((pthread_rwlock_t *) rwlock); } void janet_os_rwlock_rlock(JanetOSRWLock *rwlock) { pthread_rwlock_rdlock((pthread_rwlock_t *) rwlock); } void janet_os_rwlock_wlock(JanetOSRWLock *rwlock) { pthread_rwlock_wrlock((pthread_rwlock_t *) rwlock); } void janet_os_rwlock_runlock(JanetOSRWLock *rwlock) { pthread_rwlock_unlock((pthread_rwlock_t *) rwlock); } void janet_os_rwlock_wunlock(JanetOSRWLock *rwlock) { pthread_rwlock_unlock((pthread_rwlock_t *) rwlock); } #endif int32_t janet_abstract_incref(void *abst) { return janet_atomic_inc(&janet_abstract_head(abst)->gc.data.refcount); } int32_t janet_abstract_decref(void *abst) { return janet_atomic_dec(&janet_abstract_head(abst)->gc.data.refcount); } int32_t janet_abstract_decref_maybe_free(void *abst) { int32_t result = janet_abstract_decref(abst); if (0 == result) { JanetAbstractHead *head = janet_abstract_head(abst); if (head->type->gc) { janet_assert(!head->type->gc(head->data, head->size), "finalizer failed"); } /* Free memory */ janet_free(head); } return result; } #endif janet-1.41.2/src/core/array.c000066400000000000000000000364521514534607600157260ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "gc.h" #include "util.h" #include "state.h" #endif #include static void janet_array_impl(JanetArray *array, int32_t capacity) { Janet *data = NULL; if (capacity > 0) { janet_vm.next_collection += capacity * sizeof(Janet); data = (Janet *) janet_malloc(sizeof(Janet) * (size_t) capacity); if (NULL == data) { JANET_OUT_OF_MEMORY; } } array->count = 0; array->capacity = capacity; array->data = data; } /* Creates a new array */ JanetArray *janet_array(int32_t capacity) { JanetArray *array = janet_gcalloc(JANET_MEMORY_ARRAY, sizeof(JanetArray)); janet_array_impl(array, capacity); return array; } /* Creates a new array with weak references */ JanetArray *janet_array_weak(int32_t capacity) { JanetArray *array = janet_gcalloc(JANET_MEMORY_ARRAY_WEAK, sizeof(JanetArray)); janet_array_impl(array, capacity); return array; } /* Creates a new array from n elements. */ JanetArray *janet_array_n(const Janet *elements, int32_t n) { JanetArray *array = janet_gcalloc(JANET_MEMORY_ARRAY, sizeof(JanetArray)); array->capacity = n; array->count = n; array->data = janet_malloc(sizeof(Janet) * (size_t) n); if (!array->data) { JANET_OUT_OF_MEMORY; } safe_memcpy(array->data, elements, sizeof(Janet) * n); return array; } /* Ensure the array has enough capacity for elements */ void janet_array_ensure(JanetArray *array, int32_t capacity, int32_t growth) { Janet *newData; Janet *old = array->data; if (capacity <= array->capacity) return; int64_t new_capacity = ((int64_t) capacity) * growth; if (new_capacity > INT32_MAX) new_capacity = INT32_MAX; capacity = (int32_t) new_capacity; newData = janet_realloc(old, capacity * sizeof(Janet)); if (NULL == newData) { JANET_OUT_OF_MEMORY; } janet_vm.next_collection += (capacity - array->capacity) * sizeof(Janet); array->data = newData; array->capacity = capacity; } /* Set the count of an array. Extend with nil if needed. */ void janet_array_setcount(JanetArray *array, int32_t count) { if (count < 0) return; if (count > array->count) { int32_t i; janet_array_ensure(array, count, 1); for (i = array->count; i < count; i++) { array->data[i] = janet_wrap_nil(); } } array->count = count; } /* Push a value to the top of the array */ void janet_array_push(JanetArray *array, Janet x) { if (array->count == INT32_MAX) { janet_panic("array overflow"); } int32_t newcount = array->count + 1; janet_array_ensure(array, newcount, 2); array->data[array->count] = x; array->count = newcount; } /* Pop a value from the top of the array */ Janet janet_array_pop(JanetArray *array) { if (array->count) { return array->data[--array->count]; } else { return janet_wrap_nil(); } } /* Look at the last value in the array */ Janet janet_array_peek(JanetArray *array) { if (array->count) { return array->data[array->count - 1]; } else { return janet_wrap_nil(); } } /* C Functions */ JANET_CORE_FN(cfun_array_new, "(array/new capacity)", "Creates a new empty array with a pre-allocated capacity. The same as " "`(array)` but can be more efficient if the maximum size of an array is known.") { janet_fixarity(argc, 1); int32_t cap = janet_getinteger(argv, 0); JanetArray *array = janet_array(cap); return janet_wrap_array(array); } JANET_CORE_FN(cfun_array_weak, "(array/weak capacity)", "Creates a new empty array with a pre-allocated capacity and support for weak references. Similar to `array/new`.") { janet_fixarity(argc, 1); int32_t cap = janet_getinteger(argv, 0); JanetArray *array = janet_array_weak(cap); return janet_wrap_array(array); } JANET_CORE_FN(cfun_array_new_filled, "(array/new-filled count &opt value)", "Creates a new array of `count` elements, all set to `value`, which defaults to nil. Returns the new array.") { janet_arity(argc, 1, 2); int32_t count = janet_getnat(argv, 0); Janet x = (argc == 2) ? argv[1] : janet_wrap_nil(); JanetArray *array = janet_array(count); for (int32_t i = 0; i < count; i++) { array->data[i] = x; } array->count = count; return janet_wrap_array(array); } JANET_CORE_FN(cfun_array_fill, "(array/fill arr &opt value)", "Replace all elements of an array with `value` (defaulting to nil) without changing the length of the array. " "Returns the modified array.") { janet_arity(argc, 1, 2); JanetArray *array = janet_getarray(argv, 0); Janet x = (argc == 2) ? argv[1] : janet_wrap_nil(); for (int32_t i = 0; i < array->count; i++) { array->data[i] = x; } return argv[0]; } JANET_CORE_FN(cfun_array_pop, "(array/pop arr)", "Remove the last element of the array and return it. If the array is empty, will return nil. Modifies " "the input array.") { janet_fixarity(argc, 1); JanetArray *array = janet_getarray(argv, 0); return janet_array_pop(array); } JANET_CORE_FN(cfun_array_peek, "(array/peek arr)", "Returns the last element of the array. Does not modify the array.") { janet_fixarity(argc, 1); JanetArray *array = janet_getarray(argv, 0); return janet_array_peek(array); } JANET_CORE_FN(cfun_array_push, "(array/push arr & xs)", "Push all the elements of xs to the end of an array. Modifies the input array and returns it.") { janet_arity(argc, 1, -1); JanetArray *array = janet_getarray(argv, 0); if (INT32_MAX - argc + 1 <= array->count) { janet_panic("array overflow"); } int32_t newcount = array->count - 1 + argc; janet_array_ensure(array, newcount, 2); if (argc > 1) memcpy(array->data + array->count, argv + 1, (size_t)(argc - 1) * sizeof(Janet)); array->count = newcount; return argv[0]; } JANET_CORE_FN(cfun_array_ensure, "(array/ensure arr capacity growth)", "Ensures that the memory backing the array is large enough for `capacity` " "items at the given rate of growth. `capacity` and `growth` must be integers. " "If the backing capacity is already enough, then this function does nothing. " "Otherwise, the backing memory will be reallocated so that there is enough space.") { janet_fixarity(argc, 3); JanetArray *array = janet_getarray(argv, 0); int32_t newcount = janet_getinteger(argv, 1); int32_t growth = janet_getinteger(argv, 2); if (newcount < 1) janet_panic("expected positive integer"); janet_array_ensure(array, newcount, growth); return argv[0]; } JANET_CORE_FN(cfun_array_slice, "(array/slice arrtup &opt start end)", "Takes a slice of array or tuple from `start` to `end`. The range is half open, " "[start, end). Indexes can also be negative, indicating indexing from the " "end of the array. By default, `start` is 0 and `end` is the length of the array. " "Note that if the range is negative, it is taken as (start, end] to allow a full " "negative slice range. Returns a new array.") { JanetView view = janet_getindexed(argv, 0); JanetRange range = janet_getslice(argc, argv); JanetArray *array = janet_array(range.end - range.start); if (array->data) memcpy(array->data, view.items + range.start, sizeof(Janet) * (range.end - range.start)); array->count = range.end - range.start; return janet_wrap_array(array); } JANET_CORE_FN(cfun_array_concat, "(array/concat arr & parts)", "Concatenates a variable number of arrays (and tuples) into the first argument, " "which must be an array. If any of the parts are arrays or tuples, their elements will " "be inserted into the array. Otherwise, each part in `parts` will be appended to `arr` in order. " "Return the modified array `arr`.") { int32_t i; janet_arity(argc, 1, -1); JanetArray *array = janet_getarray(argv, 0); for (i = 1; i < argc; i++) { switch (janet_type(argv[i])) { default: janet_array_push(array, argv[i]); break; case JANET_ARRAY: case JANET_TUPLE: { int32_t j, len = 0; const Janet *vals = NULL; janet_indexed_view(argv[i], &vals, &len); if (array->data == vals) { int32_t newcount = array->count + len; janet_array_ensure(array, newcount, 2); janet_indexed_view(argv[i], &vals, &len); } for (j = 0; j < len; j++) janet_array_push(array, vals[j]); } break; } } return janet_wrap_array(array); } JANET_CORE_FN(cfun_array_join, "(array/join arr & parts)", "Join a variable number of arrays and tuples into the first argument, " "which must be an array. " "Return the modified array `arr`.") { int32_t i; janet_arity(argc, 1, -1); JanetArray *array = janet_getarray(argv, 0); for (i = 1; i < argc; i++) { int32_t j, len = 0; const Janet *vals = NULL; if (!janet_indexed_view(argv[i], &vals, &len)) { janet_panicf("expected indexed type for argument %d, got %v", i, argv[i]); } if (array->data == vals) { int32_t newcount = array->count + len; janet_array_ensure(array, newcount, 2); janet_indexed_view(argv[i], &vals, &len); } for (j = 0; j < len; j++) janet_array_push(array, vals[j]); } return janet_wrap_array(array); } JANET_CORE_FN(cfun_array_insert, "(array/insert arr at & xs)", "Insert all `xs` into array `arr` at index `at`. `at` should be an integer between " "0 and the length of the array. A negative value for `at` will index backwards from " "the end of the array, inserting after the index such that inserting at -1 appends to " "the array. Returns the array.") { size_t chunksize, restsize; janet_arity(argc, 2, -1); JanetArray *array = janet_getarray(argv, 0); int32_t at = janet_getinteger(argv, 1); if (at < 0) { at = array->count + at + 1; } if (at < 0 || at > array->count) janet_panicf("insertion index %d out of range [0,%d]", at, array->count); chunksize = (argc - 2) * sizeof(Janet); restsize = (array->count - at) * sizeof(Janet); if (INT32_MAX - (argc - 2) < array->count) { janet_panic("array overflow"); } janet_array_ensure(array, array->count + argc - 2, 2); if (restsize) { memmove(array->data + at + argc - 2, array->data + at, restsize); } safe_memcpy(array->data + at, argv + 2, chunksize); array->count += (argc - 2); return argv[0]; } JANET_CORE_FN(cfun_array_remove, "(array/remove arr at &opt n)", "Remove up to `n` elements starting at index `at` in array `arr`. `at` can index from " "the end of the array with a negative index, and `n` must be a non-negative integer. " "By default, `n` is 1. " "Returns the array.") { janet_arity(argc, 2, 3); JanetArray *array = janet_getarray(argv, 0); int32_t at = janet_getinteger(argv, 1); int32_t n = 1; if (at < 0) { at = array->count + at; } if (at < 0 || at > array->count) janet_panicf("removal index %d out of range [0,%d]", at, array->count); if (argc == 3) { n = janet_getinteger(argv, 2); if (n < 0) janet_panicf("expected non-negative integer for argument n, got %v", argv[2]); } if (at + n > array->count) { n = array->count - at; } memmove(array->data + at, array->data + at + n, (array->count - at - n) * sizeof(Janet)); array->count -= n; return argv[0]; } JANET_CORE_FN(cfun_array_trim, "(array/trim arr)", "Set the backing capacity of an array to its current length. Returns the modified array.") { janet_fixarity(argc, 1); JanetArray *array = janet_getarray(argv, 0); if (array->count) { if (array->count < array->capacity) { Janet *newData = janet_realloc(array->data, array->count * sizeof(Janet)); if (NULL == newData) { JANET_OUT_OF_MEMORY; } array->data = newData; array->capacity = array->count; } } else { array->capacity = 0; janet_free(array->data); array->data = NULL; } return argv[0]; } JANET_CORE_FN(cfun_array_clear, "(array/clear arr)", "Empties an array, setting it's count to 0 but does not free the backing capacity. " "Returns the modified array.") { janet_fixarity(argc, 1); JanetArray *array = janet_getarray(argv, 0); array->count = 0; return argv[0]; } /* Load the array module */ void janet_lib_array(JanetTable *env) { JanetRegExt array_cfuns[] = { JANET_CORE_REG("array/new", cfun_array_new), JANET_CORE_REG("array/weak", cfun_array_weak), JANET_CORE_REG("array/new-filled", cfun_array_new_filled), JANET_CORE_REG("array/fill", cfun_array_fill), JANET_CORE_REG("array/pop", cfun_array_pop), JANET_CORE_REG("array/peek", cfun_array_peek), JANET_CORE_REG("array/push", cfun_array_push), JANET_CORE_REG("array/ensure", cfun_array_ensure), JANET_CORE_REG("array/slice", cfun_array_slice), JANET_CORE_REG("array/concat", cfun_array_concat), JANET_CORE_REG("array/insert", cfun_array_insert), JANET_CORE_REG("array/remove", cfun_array_remove), JANET_CORE_REG("array/trim", cfun_array_trim), JANET_CORE_REG("array/clear", cfun_array_clear), JANET_CORE_REG("array/join", cfun_array_join), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, array_cfuns); } janet-1.41.2/src/core/asm.c000066400000000000000000001216471514534607600153710ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "util.h" #endif #include /* Conditionally compile this file */ #ifdef JANET_ASSEMBLER /* Definition for an instruction in the assembler */ typedef struct JanetInstructionDef JanetInstructionDef; struct JanetInstructionDef { const char *name; enum JanetOpCode opcode; }; /* Hold all state needed during assembly */ typedef struct JanetAssembler JanetAssembler; struct JanetAssembler { JanetAssembler *parent; JanetFuncDef *def; jmp_buf on_error; const uint8_t *errmessage; int32_t errindex; int32_t environments_capacity; int32_t defs_capacity; int32_t bytecode_count; /* Used for calculating labels */ Janet name; JanetTable labels; /* keyword -> bytecode index */ JanetTable slots; /* symbol -> slot index */ JanetTable envs; /* symbol -> environment index */ JanetTable defs; /* symbol -> funcdefs index */ }; /* Janet opcode descriptions in lexicographic order. This * allows a binary search over the elements to find the * correct opcode given a name. This works in reasonable * time and is easier to setup statically than a hash table or * prefix tree. */ static const JanetInstructionDef janet_ops[] = { {"add", JOP_ADD}, {"addim", JOP_ADD_IMMEDIATE}, {"band", JOP_BAND}, {"bnot", JOP_BNOT}, {"bor", JOP_BOR}, {"bxor", JOP_BXOR}, {"call", JOP_CALL}, {"clo", JOP_CLOSURE}, {"cmp", JOP_COMPARE}, {"cncl", JOP_CANCEL}, {"div", JOP_DIVIDE}, {"divf", JOP_DIVIDE_FLOOR}, {"divim", JOP_DIVIDE_IMMEDIATE}, {"eq", JOP_EQUALS}, {"eqim", JOP_EQUALS_IMMEDIATE}, {"err", JOP_ERROR}, {"get", JOP_GET}, {"geti", JOP_GET_INDEX}, {"gt", JOP_GREATER_THAN}, {"gte", JOP_GREATER_THAN_EQUAL}, {"gtim", JOP_GREATER_THAN_IMMEDIATE}, {"in", JOP_IN}, {"jmp", JOP_JUMP}, {"jmpif", JOP_JUMP_IF}, {"jmpni", JOP_JUMP_IF_NIL}, {"jmpnn", JOP_JUMP_IF_NOT_NIL}, {"jmpno", JOP_JUMP_IF_NOT}, {"ldc", JOP_LOAD_CONSTANT}, {"ldf", JOP_LOAD_FALSE}, {"ldi", JOP_LOAD_INTEGER}, {"ldn", JOP_LOAD_NIL}, {"lds", JOP_LOAD_SELF}, {"ldt", JOP_LOAD_TRUE}, {"ldu", JOP_LOAD_UPVALUE}, {"len", JOP_LENGTH}, {"lt", JOP_LESS_THAN}, {"lte", JOP_LESS_THAN_EQUAL}, {"ltim", JOP_LESS_THAN_IMMEDIATE}, {"mkarr", JOP_MAKE_ARRAY}, {"mkbtp", JOP_MAKE_BRACKET_TUPLE}, {"mkbuf", JOP_MAKE_BUFFER}, {"mkstr", JOP_MAKE_STRING}, {"mkstu", JOP_MAKE_STRUCT}, {"mktab", JOP_MAKE_TABLE}, {"mktup", JOP_MAKE_TUPLE}, {"mod", JOP_MODULO}, {"movf", JOP_MOVE_FAR}, {"movn", JOP_MOVE_NEAR}, {"mul", JOP_MULTIPLY}, {"mulim", JOP_MULTIPLY_IMMEDIATE}, {"neq", JOP_NOT_EQUALS}, {"neqim", JOP_NOT_EQUALS_IMMEDIATE}, {"next", JOP_NEXT}, {"noop", JOP_NOOP}, {"prop", JOP_PROPAGATE}, {"push", JOP_PUSH}, {"push2", JOP_PUSH_2}, {"push3", JOP_PUSH_3}, {"pusha", JOP_PUSH_ARRAY}, {"put", JOP_PUT}, {"puti", JOP_PUT_INDEX}, {"rem", JOP_REMAINDER}, {"res", JOP_RESUME}, {"ret", JOP_RETURN}, {"retn", JOP_RETURN_NIL}, {"setu", JOP_SET_UPVALUE}, {"sig", JOP_SIGNAL}, {"sl", JOP_SHIFT_LEFT}, {"slim", JOP_SHIFT_LEFT_IMMEDIATE}, {"sr", JOP_SHIFT_RIGHT}, {"srim", JOP_SHIFT_RIGHT_IMMEDIATE}, {"sru", JOP_SHIFT_RIGHT_UNSIGNED}, {"sruim", JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE}, {"sub", JOP_SUBTRACT}, {"subim", JOP_SUBTRACT_IMMEDIATE}, {"tcall", JOP_TAILCALL}, {"tchck", JOP_TYPECHECK} }; /* Typename aliases for tchck instruction */ typedef struct TypeAlias { const char *name; int32_t mask; } TypeAlias; static const TypeAlias type_aliases[] = { {"abstract", JANET_TFLAG_ABSTRACT}, {"array", JANET_TFLAG_ARRAY}, {"boolean", JANET_TFLAG_BOOLEAN}, {"buffer", JANET_TFLAG_BUFFER}, {"callable", JANET_TFLAG_CALLABLE}, {"cfunction", JANET_TFLAG_CFUNCTION}, {"dictionary", JANET_TFLAG_DICTIONARY}, {"fiber", JANET_TFLAG_FIBER}, {"function", JANET_TFLAG_FUNCTION}, {"indexed", JANET_TFLAG_INDEXED}, {"keyword", JANET_TFLAG_KEYWORD}, {"nil", JANET_TFLAG_NIL}, {"number", JANET_TFLAG_NUMBER}, {"pointer", JANET_TFLAG_POINTER}, {"string", JANET_TFLAG_STRING}, {"struct", JANET_TFLAG_STRUCT}, {"symbol", JANET_TFLAG_SYMBOL}, {"table", JANET_TFLAG_TABLE}, {"tuple", JANET_TFLAG_TUPLE} }; /* Deinitialize an Assembler. Does not deinitialize the parents. */ static void janet_asm_deinit(JanetAssembler *a) { janet_table_deinit(&a->slots); janet_table_deinit(&a->labels); janet_table_deinit(&a->envs); janet_table_deinit(&a->defs); } static void janet_asm_longjmp(JanetAssembler *a) { #if defined(JANET_BSD) || defined(JANET_APPLE) _longjmp(a->on_error, 1); #else longjmp(a->on_error, 1); #endif } /* Throw some kind of assembly error */ static void janet_asm_error(JanetAssembler *a, const char *message) { if (a->errindex < 0) { a->errmessage = janet_formatc("%s", message); } else { a->errmessage = janet_formatc("%s, instruction %d", message, a->errindex); } janet_asm_longjmp(a); } #define janet_asm_assert(a, c, m) do { if (!(c)) janet_asm_error((a), (m)); } while (0) /* Throw some kind of assembly error */ static void janet_asm_errorv(JanetAssembler *a, const uint8_t *m) { a->errmessage = m; janet_asm_longjmp(a); } /* Add a closure environment to the assembler. Sub funcdefs may need * to reference outer function environments, and may change the outer environment. * Returns the index of the environment in the assembler's environments, or -1 * if not found. */ static int32_t janet_asm_addenv(JanetAssembler *a, Janet envname) { Janet check; JanetFuncDef *def = a->def; int32_t envindex; int32_t res; if (janet_equals(a->name, envname)) { return -1; } /* Check for memoized value */ check = janet_table_get(&a->envs, envname); if (janet_checktype(check, JANET_NUMBER)) { return (int32_t) janet_unwrap_number(check); } if (NULL == a->parent) return -2; res = janet_asm_addenv(a->parent, envname); if (res < -1) { return res; } envindex = def->environments_length; janet_table_put(&a->envs, envname, janet_wrap_number(envindex)); if (envindex >= a->environments_capacity) { int32_t newcap = 2 * envindex; def->environments = janet_realloc(def->environments, newcap * sizeof(int32_t)); if (NULL == def->environments) { JANET_OUT_OF_MEMORY; } a->environments_capacity = newcap; } def->environments[envindex] = (int32_t) res; def->environments_length = envindex + 1; return envindex; } /* Parse an argument to an assembly instruction, and return the result as an * integer. This integer will need to be bounds checked. */ static int32_t doarg_1( JanetAssembler *a, enum JanetOpArgType argtype, Janet x) { int32_t ret = -1; JanetTable *c; switch (argtype) { default: c = NULL; break; case JANET_OAT_SLOT: c = &a->slots; break; case JANET_OAT_ENVIRONMENT: c = &a->envs; break; case JANET_OAT_LABEL: c = &a->labels; break; case JANET_OAT_FUNCDEF: c = &a->defs; break; } switch (janet_type(x)) { default: goto error; break; case JANET_NUMBER: { double y = janet_unwrap_number(x); if (janet_checkintrange(y)) { ret = (int32_t) y; } else { goto error; } break; } case JANET_TUPLE: { const Janet *t = janet_unwrap_tuple(x); if (argtype == JANET_OAT_TYPE) { int32_t i = 0; ret = 0; for (i = 0; i < janet_tuple_length(t); i++) { ret |= doarg_1(a, JANET_OAT_SIMPLETYPE, t[i]); } } else { goto error; } break; } case JANET_KEYWORD: { if (NULL != c && argtype == JANET_OAT_LABEL) { Janet result = janet_table_get(c, x); if (janet_checktype(result, JANET_NUMBER)) { ret = janet_unwrap_integer(result) - a->bytecode_count; } else { goto error; } } else if (argtype == JANET_OAT_TYPE || argtype == JANET_OAT_SIMPLETYPE) { const TypeAlias *alias = janet_strbinsearch( &type_aliases, sizeof(type_aliases) / sizeof(TypeAlias), sizeof(TypeAlias), janet_unwrap_keyword(x)); if (alias) { ret = alias->mask; } else { janet_asm_errorv(a, janet_formatc("unknown type %v", x)); } } else { goto error; } break; } case JANET_SYMBOL: { if (NULL != c) { Janet result = janet_table_get(c, x); if (janet_checktype(result, JANET_NUMBER)) { ret = (int32_t) janet_unwrap_number(result); } else { janet_asm_errorv(a, janet_formatc("unknown name %v", x)); } } else { goto error; } if (argtype == JANET_OAT_ENVIRONMENT && ret == -1) { /* Add a new env */ ret = janet_asm_addenv(a, x); if (ret < -1) { janet_asm_errorv(a, janet_formatc("unknown environment %v", x)); } } break; } } if (argtype == JANET_OAT_SLOT && ret >= a->def->slotcount) a->def->slotcount = (int32_t) ret + 1; return ret; error: janet_asm_errorv(a, janet_formatc("error parsing instruction argument %v", x)); return 0; } /* Parse a single argument to an instruction. Trims it as well as * try to convert arguments to bit patterns */ static uint32_t doarg( JanetAssembler *a, enum JanetOpArgType argtype, int nth, int nbytes, int hassign, Janet x) { int32_t arg = doarg_1(a, argtype, x); /* Calculate the min and max values that can be stored given * nbytes, and whether or not the storage is signed */ int32_t max = (1 << ((nbytes << 3) - hassign)) - 1; int32_t min = hassign ? -max - 1 : 0; if (arg < min) janet_asm_errorv(a, janet_formatc("instruction argument %v is too small, must be %d byte%s", x, nbytes, nbytes > 1 ? "s" : "")); if (arg > max) janet_asm_errorv(a, janet_formatc("instruction argument %v is too large, must be %d byte%s", x, nbytes, nbytes > 1 ? "s" : "")); return ((uint32_t) arg) << (nth << 3); } /* Provide parsing methods for the different kinds of arguments */ static uint32_t read_instruction( JanetAssembler *a, const JanetInstructionDef *idef, const Janet *argt) { uint32_t instr = idef->opcode; enum JanetInstructionType type = janet_instructions[idef->opcode]; switch (type) { case JINT_0: { if (janet_tuple_length(argt) != 1) janet_asm_error(a, "expected 0 arguments: (op)"); break; } case JINT_S: { if (janet_tuple_length(argt) != 2) janet_asm_error(a, "expected 1 argument: (op, slot)"); instr |= doarg(a, JANET_OAT_SLOT, 1, 2, 0, argt[1]); break; } case JINT_L: { if (janet_tuple_length(argt) != 2) janet_asm_error(a, "expected 1 argument: (op, label)"); instr |= doarg(a, JANET_OAT_LABEL, 1, 3, 1, argt[1]); break; } case JINT_SS: { if (janet_tuple_length(argt) != 3) janet_asm_error(a, "expected 2 arguments: (op, slot, slot)"); instr |= doarg(a, JANET_OAT_SLOT, 1, 1, 0, argt[1]); instr |= doarg(a, JANET_OAT_SLOT, 2, 2, 0, argt[2]); break; } case JINT_SL: { if (janet_tuple_length(argt) != 3) janet_asm_error(a, "expected 2 arguments: (op, slot, label)"); instr |= doarg(a, JANET_OAT_SLOT, 1, 1, 0, argt[1]); instr |= doarg(a, JANET_OAT_LABEL, 2, 2, 1, argt[2]); break; } case JINT_ST: { if (janet_tuple_length(argt) != 3) janet_asm_error(a, "expected 2 arguments: (op, slot, type)"); instr |= doarg(a, JANET_OAT_SLOT, 1, 1, 0, argt[1]); instr |= doarg(a, JANET_OAT_TYPE, 2, 2, 0, argt[2]); break; } case JINT_SI: case JINT_SU: { if (janet_tuple_length(argt) != 3) janet_asm_error(a, "expected 2 arguments: (op, slot, integer)"); instr |= doarg(a, JANET_OAT_SLOT, 1, 1, 0, argt[1]); instr |= doarg(a, JANET_OAT_INTEGER, 2, 2, type == JINT_SI, argt[2]); break; } case JINT_SD: { if (janet_tuple_length(argt) != 3) janet_asm_error(a, "expected 2 arguments: (op, slot, funcdef)"); instr |= doarg(a, JANET_OAT_SLOT, 1, 1, 0, argt[1]); instr |= doarg(a, JANET_OAT_FUNCDEF, 2, 2, 0, argt[2]); break; } case JINT_SSS: { if (janet_tuple_length(argt) != 4) janet_asm_error(a, "expected 3 arguments: (op, slot, slot, slot)"); instr |= doarg(a, JANET_OAT_SLOT, 1, 1, 0, argt[1]); instr |= doarg(a, JANET_OAT_SLOT, 2, 1, 0, argt[2]); instr |= doarg(a, JANET_OAT_SLOT, 3, 1, 0, argt[3]); break; } case JINT_SSI: case JINT_SSU: { if (janet_tuple_length(argt) != 4) janet_asm_error(a, "expected 3 arguments: (op, slot, slot, integer)"); instr |= doarg(a, JANET_OAT_SLOT, 1, 1, 0, argt[1]); instr |= doarg(a, JANET_OAT_SLOT, 2, 1, 0, argt[2]); instr |= doarg(a, JANET_OAT_INTEGER, 3, 1, type == JINT_SSI, argt[3]); break; } case JINT_SES: { JanetAssembler *b = a; uint32_t env; if (janet_tuple_length(argt) != 4) janet_asm_error(a, "expected 3 arguments: (op, slot, environment, envslot)"); instr |= doarg(a, JANET_OAT_SLOT, 1, 1, 0, argt[1]); env = doarg(a, JANET_OAT_ENVIRONMENT, 0, 1, 0, argt[2]); instr |= env << 16; for (env += 1; env > 0; env--) { b = b->parent; if (NULL == b) janet_asm_error(a, "invalid environment index"); } instr |= doarg(b, JANET_OAT_SLOT, 3, 1, 0, argt[3]); break; } case JINT_SC: { if (janet_tuple_length(argt) != 3) janet_asm_error(a, "expected 2 arguments: (op, slot, constant)"); instr |= doarg(a, JANET_OAT_SLOT, 1, 1, 0, argt[1]); instr |= doarg(a, JANET_OAT_CONSTANT, 2, 2, 0, argt[2]); break; } } return instr; } /* Helper to get from a structure */ static Janet janet_get1(Janet ds, Janet key) { switch (janet_type(ds)) { default: return janet_wrap_nil(); case JANET_TABLE: return janet_table_get(janet_unwrap_table(ds), key); case JANET_STRUCT: return janet_struct_get(janet_unwrap_struct(ds), key); } } /* Helper to assembly. Return the assembly result */ static JanetAssembleResult janet_asm1(JanetAssembler *parent, Janet source, int flags) { JanetAssembleResult result; JanetAssembler a; Janet s = source; JanetFuncDef *def; int32_t count, i; const Janet *arr; Janet x; (void) flags; /* Initialize funcdef */ def = janet_funcdef_alloc(); /* Initialize Assembler */ a.def = def; a.parent = parent; a.errmessage = NULL; a.errindex = 0; a.environments_capacity = 0; a.bytecode_count = 0; a.defs_capacity = 0; a.name = janet_wrap_nil(); janet_table_init(&a.labels, 0); janet_table_init(&a.slots, 0); janet_table_init(&a.envs, 0); janet_table_init(&a.defs, 0); /* Set error jump */ #if defined(JANET_BSD) || defined(JANET_APPLE) if (_setjmp(a.on_error)) { #else if (setjmp(a.on_error)) { #endif if (NULL != a.parent) { janet_asm_deinit(&a); a.parent->errmessage = a.errmessage; janet_asm_longjmp(a.parent); } result.funcdef = NULL; result.error = a.errmessage; result.status = JANET_ASSEMBLE_ERROR; janet_asm_deinit(&a); return result; } janet_asm_assert(&a, janet_checktype(s, JANET_STRUCT) || janet_checktype(s, JANET_TABLE), "expected struct or table for assembly source"); /* Check for function name */ a.name = janet_get1(s, janet_ckeywordv("name")); if (!janet_checktype(a.name, JANET_NIL)) { def->name = janet_to_string(a.name); } /* Set function arity */ x = janet_get1(s, janet_ckeywordv("arity")); def->arity = janet_checkint(x) ? janet_unwrap_integer(x) : 0; janet_asm_assert(&a, def->arity >= 0, "arity must be non-negative"); x = janet_get1(s, janet_ckeywordv("max-arity")); def->max_arity = janet_checkint(x) ? janet_unwrap_integer(x) : def->arity; janet_asm_assert(&a, def->max_arity >= def->arity, "max-arity must be greater than or equal to arity"); x = janet_get1(s, janet_ckeywordv("min-arity")); def->min_arity = janet_checkint(x) ? janet_unwrap_integer(x) : def->arity; janet_asm_assert(&a, def->min_arity <= def->arity, "min-arity must be less than or equal to arity"); /* Check vararg */ x = janet_get1(s, janet_ckeywordv("vararg")); if (janet_truthy(x)) def->flags |= JANET_FUNCDEF_FLAG_VARARG; /* Initialize slotcount */ def->slotcount = !!(def->flags & JANET_FUNCDEF_FLAG_VARARG) + def->arity; /* Check structarg */ x = janet_get1(s, janet_ckeywordv("structarg")); if (janet_truthy(x)) def->flags |= JANET_FUNCDEF_FLAG_STRUCTARG; /* Check namedarg */ x = janet_get1(s, janet_ckeywordv("namedargs")); if (janet_checkint(x)) { def->flags |= JANET_FUNCDEF_FLAG_NAMEDARGS; def->named_args_count = janet_unwrap_integer(x); } /* Check source */ x = janet_get1(s, janet_ckeywordv("source")); if (janet_checktype(x, JANET_STRING)) def->source = janet_unwrap_string(x); /* Create slot aliases */ x = janet_get1(s, janet_ckeywordv("slots")); if (janet_indexed_view(x, &arr, &count)) { for (i = 0; i < count; i++) { Janet v = arr[i]; if (janet_checktype(v, JANET_TUPLE)) { const Janet *t = janet_unwrap_tuple(v); int32_t j; for (j = 0; j < janet_tuple_length(t); j++) { if (!janet_checktype(t[j], JANET_SYMBOL)) janet_asm_error(&a, "slot names must be symbols"); janet_table_put(&a.slots, t[j], janet_wrap_integer(i)); } } else if (janet_checktype(v, JANET_SYMBOL)) { janet_table_put(&a.slots, v, janet_wrap_integer(i)); } else { janet_asm_error(&a, "slot names must be symbols or tuple of symbols"); } } } /* Parse constants */ x = janet_get1(s, janet_ckeywordv("constants")); if (janet_indexed_view(x, &arr, &count)) { def->constants_length = count; def->constants = janet_malloc(sizeof(Janet) * (size_t) count); if (NULL == def->constants) { JANET_OUT_OF_MEMORY; } for (i = 0; i < count; i++) { Janet ct = arr[i]; def->constants[i] = ct; } } else { def->constants = NULL; def->constants_length = 0; } /* Parse sub funcdefs */ x = janet_get1(s, janet_ckeywordv("closures")); if (janet_checktype(x, JANET_NIL)) { x = janet_get1(s, janet_ckeywordv("defs")); } if (janet_indexed_view(x, &arr, &count)) { int32_t i; for (i = 0; i < count; i++) { JanetAssembleResult subres; Janet subname; int32_t newlen; subres = janet_asm1(&a, arr[i], flags); if (subres.status != JANET_ASSEMBLE_OK) { janet_asm_errorv(&a, subres.error); } subname = janet_get1(arr[i], janet_ckeywordv("name")); if (!janet_checktype(subname, JANET_NIL)) { janet_table_put(&a.defs, subname, janet_wrap_integer(def->defs_length)); } newlen = def->defs_length + 1; if (a.defs_capacity < newlen) { int32_t newcap = newlen; def->defs = janet_realloc(def->defs, newcap * sizeof(JanetFuncDef *)); if (NULL == def->defs) { JANET_OUT_OF_MEMORY; } a.defs_capacity = newcap; } def->defs[def->defs_length] = subres.funcdef; def->defs_length = newlen; } } /* Parse bytecode and labels */ x = janet_get1(s, janet_ckeywordv("bytecode")); if (janet_indexed_view(x, &arr, &count)) { /* Do labels and find length */ int32_t blength = 0; for (i = 0; i < count; ++i) { Janet instr = arr[i]; if (janet_checktype(instr, JANET_KEYWORD)) { janet_table_put(&a.labels, instr, janet_wrap_integer(blength)); } else if (janet_checktype(instr, JANET_TUPLE)) { blength++; } else { a.errindex = i; janet_asm_error(&a, "expected assembly instruction"); } } /* Allocate bytecode array */ def->bytecode_length = blength; def->bytecode = janet_malloc(sizeof(uint32_t) * (size_t) blength); if (NULL == def->bytecode) { JANET_OUT_OF_MEMORY; } /* Do bytecode */ for (i = 0; i < count; ++i) { Janet instr = arr[i]; if (janet_checktype(instr, JANET_KEYWORD)) { continue; } else { uint32_t op; const JanetInstructionDef *idef; const Janet *t; a.errindex = i; janet_asm_assert(&a, janet_checktype(instr, JANET_TUPLE), "expected tuple"); t = janet_unwrap_tuple(instr); if (janet_tuple_length(t) == 0) { op = 0; } else { janet_asm_assert(&a, janet_checktype(t[0], JANET_SYMBOL), "expected symbol in assembly instruction"); idef = janet_strbinsearch( &janet_ops, sizeof(janet_ops) / sizeof(JanetInstructionDef), sizeof(JanetInstructionDef), janet_unwrap_symbol(t[0])); if (NULL == idef) janet_asm_errorv(&a, janet_formatc("unknown instruction %v", t[0])); op = read_instruction(&a, idef, t); } def->bytecode[a.bytecode_count++] = op; } } } else { janet_asm_error(&a, "bytecode expected"); } a.errindex = -1; /* Check for source mapping */ x = janet_get1(s, janet_ckeywordv("sourcemap")); if (janet_indexed_view(x, &arr, &count)) { janet_asm_assert(&a, count == def->bytecode_length, "sourcemap must have the same length as the bytecode"); def->sourcemap = janet_malloc(sizeof(JanetSourceMapping) * (size_t) count); if (NULL == def->sourcemap) { JANET_OUT_OF_MEMORY; } for (i = 0; i < count; i++) { const Janet *tup; Janet entry = arr[i]; JanetSourceMapping mapping; if (!janet_checktype(entry, JANET_TUPLE)) { janet_asm_error(&a, "expected tuple"); } tup = janet_unwrap_tuple(entry); if (!janet_checkint(tup[0])) { janet_asm_error(&a, "expected integer"); } if (!janet_checkint(tup[1])) { janet_asm_error(&a, "expected integer"); } mapping.line = janet_unwrap_integer(tup[0]); mapping.column = janet_unwrap_integer(tup[1]); def->sourcemap[i] = mapping; } } /* Set symbolmap */ def->symbolmap = NULL; def->symbolmap_length = 0; x = janet_get1(s, janet_ckeywordv("symbolmap")); if (janet_indexed_view(x, &arr, &count)) { def->symbolmap_length = count; def->symbolmap = janet_malloc(sizeof(JanetSymbolMap) * (size_t)count); if (NULL == def->symbolmap) { JANET_OUT_OF_MEMORY; } for (i = 0; i < count; i++) { const Janet *tup; Janet entry = arr[i]; JanetSymbolMap ss; if (!janet_checktype(entry, JANET_TUPLE)) { janet_asm_error(&a, "expected tuple"); } tup = janet_unwrap_tuple(entry); if (janet_keyeq(tup[0], "upvalue")) { ss.birth_pc = UINT32_MAX; } else if (!janet_checkint(tup[0])) { janet_asm_error(&a, "expected integer"); } else { ss.birth_pc = janet_unwrap_integer(tup[0]); } if (!janet_checkint(tup[1])) { janet_asm_error(&a, "expected integer"); } if (!janet_checkint(tup[2])) { janet_asm_error(&a, "expected integer"); } if (!janet_checktype(tup[3], JANET_SYMBOL)) { janet_asm_error(&a, "expected symbol"); } ss.death_pc = janet_unwrap_integer(tup[1]); ss.slot_index = janet_unwrap_integer(tup[2]); ss.symbol = janet_unwrap_symbol(tup[3]); def->symbolmap[i] = ss; } } if (def->symbolmap_length) def->flags |= JANET_FUNCDEF_FLAG_HASSYMBOLMAP; /* Set environments */ x = janet_get1(s, janet_ckeywordv("environments")); if (janet_indexed_view(x, &arr, &count)) { def->environments_length = count; if (def->environments_length) { def->environments = janet_realloc(def->environments, def->environments_length * sizeof(int32_t)); } for (int32_t i = 0; i < count; i++) { if (!janet_checkint(arr[i])) { janet_asm_error(&a, "expected integer"); } def->environments[i] = janet_unwrap_integer(arr[i]); } } if (def->environments_length && NULL == def->environments) { JANET_OUT_OF_MEMORY; } /* Verify the func def */ int verify_status = janet_verify(def); if (verify_status) { janet_asm_errorv(&a, janet_formatc("invalid assembly (%d)", verify_status)); } /* Add final flags */ janet_def_addflags(def); /* Finish everything and return funcdef */ janet_asm_deinit(&a); result.error = NULL; result.funcdef = def; result.status = JANET_ASSEMBLE_OK; return result; } /* Assemble a function */ JanetAssembleResult janet_asm(Janet source, int flags) { return janet_asm1(NULL, source, flags); } /* Disassembly */ /* Find the definition of an instruction given the instruction word. Return * NULL if not found. */ static const JanetInstructionDef *janet_asm_reverse_lookup(uint32_t instr) { size_t i; uint32_t opcode = instr & 0x7F; for (i = 0; i < sizeof(janet_ops) / sizeof(JanetInstructionDef); i++) { const JanetInstructionDef *def = janet_ops + i; if (def->opcode == opcode) return def; } return NULL; } /* Create some constant sized tuples */ static const Janet *tup1(Janet x) { Janet *tup = janet_tuple_begin(1); tup[0] = x; return janet_tuple_end(tup); } static const Janet *tup2(Janet x, Janet y) { Janet *tup = janet_tuple_begin(2); tup[0] = x; tup[1] = y; return janet_tuple_end(tup); } static const Janet *tup3(Janet x, Janet y, Janet z) { Janet *tup = janet_tuple_begin(3); tup[0] = x; tup[1] = y; tup[2] = z; return janet_tuple_end(tup); } static const Janet *tup4(Janet w, Janet x, Janet y, Janet z) { Janet *tup = janet_tuple_begin(4); tup[0] = w; tup[1] = x; tup[2] = y; tup[3] = z; return janet_tuple_end(tup); } /* Given an argument, convert it to the appropriate integer or symbol */ Janet janet_asm_decode_instruction(uint32_t instr) { const JanetInstructionDef *def = janet_asm_reverse_lookup(instr); Janet name; if (NULL == def) { return janet_wrap_integer((int32_t)instr); } name = janet_csymbolv(def->name); const Janet *ret = NULL; #define oparg(shift, mask) ((instr >> ((shift) << 3)) & (mask)) switch (janet_instructions[def->opcode]) { case JINT_0: ret = tup1(name); break; case JINT_S: ret = tup2(name, janet_wrap_integer(oparg(1, 0xFFFFFF))); break; case JINT_L: ret = tup2(name, janet_wrap_integer((int32_t)instr >> 8)); break; case JINT_SS: case JINT_ST: case JINT_SC: case JINT_SU: case JINT_SD: ret = tup3(name, janet_wrap_integer(oparg(1, 0xFF)), janet_wrap_integer(oparg(2, 0xFFFF))); break; case JINT_SI: case JINT_SL: ret = tup3(name, janet_wrap_integer(oparg(1, 0xFF)), janet_wrap_integer((int32_t)instr >> 16)); break; case JINT_SSS: case JINT_SES: case JINT_SSU: ret = tup4(name, janet_wrap_integer(oparg(1, 0xFF)), janet_wrap_integer(oparg(2, 0xFF)), janet_wrap_integer(oparg(3, 0xFF))); break; case JINT_SSI: ret = tup4(name, janet_wrap_integer(oparg(1, 0xFF)), janet_wrap_integer(oparg(2, 0xFF)), janet_wrap_integer((int32_t)instr >> 24)); break; } #undef oparg if (ret) { /* Check if break point set */ if (instr & 0x80) { janet_tuple_flag(ret) |= JANET_TUPLE_FLAG_BRACKETCTOR; } return janet_wrap_tuple(ret); } return janet_wrap_nil(); } /* * Disasm sections */ static Janet janet_disasm_arity(JanetFuncDef *def) { return janet_wrap_integer(def->arity); } static Janet janet_disasm_min_arity(JanetFuncDef *def) { return janet_wrap_integer(def->min_arity); } static Janet janet_disasm_max_arity(JanetFuncDef *def) { return janet_wrap_integer(def->max_arity); } static Janet janet_disasm_slotcount(JanetFuncDef *def) { return janet_wrap_integer(def->slotcount); } static Janet janet_disasm_symbolslots(JanetFuncDef *def) { if (def->symbolmap == NULL) { return janet_wrap_nil(); } JanetArray *symbolslots = janet_array(def->symbolmap_length); Janet upvaluekw = janet_ckeywordv("upvalue"); for (int32_t i = 0; i < def->symbolmap_length; i++) { JanetSymbolMap ss = def->symbolmap[i]; Janet *t = janet_tuple_begin(4); if (ss.birth_pc == UINT32_MAX) { t[0] = upvaluekw; } else { t[0] = janet_wrap_integer(ss.birth_pc); } t[1] = janet_wrap_integer(ss.death_pc); t[2] = janet_wrap_integer(ss.slot_index); t[3] = janet_wrap_symbol(ss.symbol); symbolslots->data[i] = janet_wrap_tuple(janet_tuple_end(t)); } symbolslots->count = def->symbolmap_length; return janet_wrap_array(symbolslots); } static Janet janet_disasm_bytecode(JanetFuncDef *def) { JanetArray *bcode = janet_array(def->bytecode_length); for (int32_t i = 0; i < def->bytecode_length; i++) { bcode->data[i] = janet_asm_decode_instruction(def->bytecode[i]); } bcode->count = def->bytecode_length; return janet_wrap_array(bcode); } static Janet janet_disasm_source(JanetFuncDef *def) { if (def->source != NULL) return janet_wrap_string(def->source); return janet_wrap_nil(); } static Janet janet_disasm_name(JanetFuncDef *def) { if (def->name != NULL) return janet_wrap_string(def->name); return janet_wrap_nil(); } static Janet janet_disasm_vararg(JanetFuncDef *def) { return janet_wrap_boolean(def->flags & JANET_FUNCDEF_FLAG_VARARG); } static Janet janet_disasm_structarg(JanetFuncDef *def) { return janet_wrap_boolean(def->flags & JANET_FUNCDEF_FLAG_STRUCTARG); } static Janet janet_disasm_namedargs(JanetFuncDef *def) { if (def->flags & JANET_FUNCDEF_FLAG_NAMEDARGS) { return janet_wrap_integer(def->named_args_count); } else { return janet_wrap_nil(); } } static Janet janet_disasm_constants(JanetFuncDef *def) { JanetArray *constants = janet_array(def->constants_length); for (int32_t i = 0; i < def->constants_length; i++) { constants->data[i] = def->constants[i]; } constants->count = def->constants_length; return janet_wrap_array(constants); } static Janet janet_disasm_sourcemap(JanetFuncDef *def) { if (NULL == def->sourcemap) return janet_wrap_nil(); JanetArray *sourcemap = janet_array(def->bytecode_length); for (int32_t i = 0; i < def->bytecode_length; i++) { Janet *t = janet_tuple_begin(2); JanetSourceMapping mapping = def->sourcemap[i]; t[0] = janet_wrap_integer(mapping.line); t[1] = janet_wrap_integer(mapping.column); sourcemap->data[i] = janet_wrap_tuple(janet_tuple_end(t)); } sourcemap->count = def->bytecode_length; return janet_wrap_array(sourcemap); } static Janet janet_disasm_environments(JanetFuncDef *def) { JanetArray *envs = janet_array(def->environments_length); for (int32_t i = 0; i < def->environments_length; i++) { envs->data[i] = janet_wrap_integer(def->environments[i]); } envs->count = def->environments_length; return janet_wrap_array(envs); } static Janet janet_disasm_defs(JanetFuncDef *def) { JanetArray *defs = janet_array(def->defs_length); for (int32_t i = 0; i < def->defs_length; i++) { defs->data[i] = janet_disasm(def->defs[i]); } defs->count = def->defs_length; return janet_wrap_array(defs); } Janet janet_disasm(JanetFuncDef *def) { JanetTable *ret = janet_table(10); janet_table_put(ret, janet_ckeywordv("arity"), janet_disasm_arity(def)); janet_table_put(ret, janet_ckeywordv("min-arity"), janet_disasm_min_arity(def)); janet_table_put(ret, janet_ckeywordv("max-arity"), janet_disasm_max_arity(def)); janet_table_put(ret, janet_ckeywordv("bytecode"), janet_disasm_bytecode(def)); janet_table_put(ret, janet_ckeywordv("source"), janet_disasm_source(def)); janet_table_put(ret, janet_ckeywordv("vararg"), janet_disasm_vararg(def)); janet_table_put(ret, janet_ckeywordv("structarg"), janet_disasm_structarg(def)); janet_table_put(ret, janet_ckeywordv("namedargs"), janet_disasm_namedargs(def)); janet_table_put(ret, janet_ckeywordv("name"), janet_disasm_name(def)); janet_table_put(ret, janet_ckeywordv("slotcount"), janet_disasm_slotcount(def)); janet_table_put(ret, janet_ckeywordv("symbolmap"), janet_disasm_symbolslots(def)); janet_table_put(ret, janet_ckeywordv("constants"), janet_disasm_constants(def)); janet_table_put(ret, janet_ckeywordv("sourcemap"), janet_disasm_sourcemap(def)); janet_table_put(ret, janet_ckeywordv("environments"), janet_disasm_environments(def)); janet_table_put(ret, janet_ckeywordv("defs"), janet_disasm_defs(def)); return janet_wrap_struct(janet_table_to_struct(ret)); } JANET_CORE_FN(cfun_asm, "(asm assembly)", "Returns a new function that is the compiled result of the assembly.\n" "The syntax for the assembly can be found on the Janet website, and should correspond\n" "to the return value of disasm. Will throw an\n" "error on invalid assembly.") { janet_sandbox_assert(JANET_SANDBOX_ASM); janet_fixarity(argc, 1); JanetAssembleResult res; res = janet_asm(argv[0], 0); if (res.status != JANET_ASSEMBLE_OK) { janet_panics(res.error ? res.error : janet_cstring("invalid assembly")); } return janet_wrap_function(janet_thunk(res.funcdef)); } JANET_CORE_FN(cfun_disasm, "(disasm func &opt field)", "Returns assembly that could be used to compile the given function. " "func must be a function, not a c function. Will throw on error on a badly " "typed argument. If given a field name, will only return that part of the function assembly. " "Possible fields are:\n\n" "* :arity - number of required and optional arguments.\n" "* :min-arity - minimum number of arguments function can be called with.\n" "* :max-arity - maximum number of arguments function can be called with.\n" "* :vararg - true if function can take a variable number of arguments.\n" "* :structarg - true if function can take a variable number of arguments using the &keys option.\n" "* :namedargs - if function can take a variable number of arguments using the &named option, this will be the number of named arguments.\n" "* :bytecode - array of parsed bytecode instructions. Each instruction is a tuple.\n" "* :source - name of source file that this function was compiled from.\n" "* :name - name of function.\n" "* :slotcount - how many virtual registers, or slots, this function uses. Corresponds to stack space used by function.\n" "* :symbolmap - all symbols and their slots.\n" "* :constants - an array of constants referenced by this function.\n" "* :sourcemap - a mapping of each bytecode instruction to a line and column in the source file.\n" "* :environments - an internal mapping of which enclosing functions are referenced for bindings.\n" "* :defs - other function definitions that this function may instantiate.\n") { janet_sandbox_assert(JANET_SANDBOX_ASM); janet_arity(argc, 1, 2); JanetFunction *f = janet_getfunction(argv, 0); if (argc == 2) { JanetKeyword kw = janet_getkeyword(argv, 1); if (!janet_cstrcmp(kw, "arity")) return janet_disasm_arity(f->def); if (!janet_cstrcmp(kw, "min-arity")) return janet_disasm_min_arity(f->def); if (!janet_cstrcmp(kw, "max-arity")) return janet_disasm_max_arity(f->def); if (!janet_cstrcmp(kw, "bytecode")) return janet_disasm_bytecode(f->def); if (!janet_cstrcmp(kw, "source")) return janet_disasm_source(f->def); if (!janet_cstrcmp(kw, "name")) return janet_disasm_name(f->def); if (!janet_cstrcmp(kw, "vararg")) return janet_disasm_vararg(f->def); if (!janet_cstrcmp(kw, "structarg")) return janet_disasm_structarg(f->def); if (!janet_cstrcmp(kw, "namedargs")) return janet_disasm_namedargs(f->def); if (!janet_cstrcmp(kw, "slotcount")) return janet_disasm_slotcount(f->def); if (!janet_cstrcmp(kw, "constants")) return janet_disasm_constants(f->def); if (!janet_cstrcmp(kw, "sourcemap")) return janet_disasm_sourcemap(f->def); if (!janet_cstrcmp(kw, "environments")) return janet_disasm_environments(f->def); if (!janet_cstrcmp(kw, "defs")) return janet_disasm_defs(f->def); janet_panicf("unknown disasm key %v", argv[1]); } else { return janet_disasm(f->def); } } /* Load the library */ void janet_lib_asm(JanetTable *env) { JanetRegExt asm_cfuns[] = { JANET_CORE_REG("asm", cfun_asm), JANET_CORE_REG("disasm", cfun_disasm), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, asm_cfuns); } #endif janet-1.41.2/src/core/buffer.c000066400000000000000000000632011514534607600160510ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "gc.h" #include "util.h" #include "state.h" #endif /* Allow for managed buffers that cannot realloc/free their backing memory */ static void janet_buffer_can_realloc(JanetBuffer *buffer) { if (buffer->gc.flags & JANET_BUFFER_FLAG_NO_REALLOC) { janet_panic("buffer cannot reallocate foreign memory"); } } /* Initialize a buffer */ static JanetBuffer *janet_buffer_init_impl(JanetBuffer *buffer, int32_t capacity) { uint8_t *data = NULL; if (capacity < 4) capacity = 4; janet_gcpressure(capacity); data = janet_malloc(sizeof(uint8_t) * (size_t) capacity); if (NULL == data) { JANET_OUT_OF_MEMORY; } buffer->count = 0; buffer->capacity = capacity; buffer->data = data; return buffer; } /* Initialize a buffer */ JanetBuffer *janet_buffer_init(JanetBuffer *buffer, int32_t capacity) { janet_buffer_init_impl(buffer, capacity); buffer->gc.data.next = NULL; buffer->gc.flags = JANET_MEM_DISABLED; return buffer; } /* Initialize an unmanaged buffer */ JanetBuffer *janet_pointer_buffer_unsafe(void *memory, int32_t capacity, int32_t count) { if (count < 0) janet_panic("count < 0"); if (capacity < count) janet_panic("capacity < count"); JanetBuffer *buffer = janet_gcalloc(JANET_MEMORY_BUFFER, sizeof(JanetBuffer)); buffer->gc.flags |= JANET_BUFFER_FLAG_NO_REALLOC; buffer->capacity = capacity; buffer->count = count; buffer->data = (uint8_t *) memory; return buffer; } /* Deinitialize a buffer (free data memory) */ void janet_buffer_deinit(JanetBuffer *buffer) { if (!(buffer->gc.flags & JANET_BUFFER_FLAG_NO_REALLOC)) { janet_free(buffer->data); buffer->data = NULL; } } /* Initialize a buffer */ JanetBuffer *janet_buffer(int32_t capacity) { JanetBuffer *buffer = janet_gcalloc(JANET_MEMORY_BUFFER, sizeof(JanetBuffer)); return janet_buffer_init_impl(buffer, capacity); } /* Ensure that the buffer has enough internal capacity */ void janet_buffer_ensure(JanetBuffer *buffer, int32_t capacity, int32_t growth) { uint8_t *new_data; uint8_t *old = buffer->data; if (capacity <= buffer->capacity) return; janet_buffer_can_realloc(buffer); int64_t big_capacity = ((int64_t) capacity) * growth; capacity = big_capacity > INT32_MAX ? INT32_MAX : (int32_t) big_capacity; janet_gcpressure(capacity - buffer->capacity); new_data = janet_realloc(old, (size_t) capacity * sizeof(uint8_t)); if (NULL == new_data) { JANET_OUT_OF_MEMORY; } buffer->data = new_data; buffer->capacity = capacity; } /* Ensure that the buffer has enough internal capacity */ void janet_buffer_setcount(JanetBuffer *buffer, int32_t count) { if (count < 0) return; if (count > buffer->count) { int32_t oldcount = buffer->count; janet_buffer_ensure(buffer, count, 1); memset(buffer->data + oldcount, 0, count - oldcount); } buffer->count = count; } /* Adds capacity for enough extra bytes to the buffer. Ensures that the * next n bytes pushed to the buffer will not cause a reallocation */ void janet_buffer_extra(JanetBuffer *buffer, int32_t n) { /* Check for buffer overflow */ if ((int64_t)n + buffer->count > INT32_MAX) { janet_panic("buffer overflow"); } int32_t new_size = buffer->count + n; if (new_size > buffer->capacity) { janet_buffer_can_realloc(buffer); int32_t new_capacity = (new_size > (INT32_MAX / 2)) ? INT32_MAX : (new_size * 2); uint8_t *new_data = janet_realloc(buffer->data, new_capacity * sizeof(uint8_t)); janet_gcpressure(new_capacity - buffer->capacity); if (NULL == new_data) { JANET_OUT_OF_MEMORY; } buffer->data = new_data; buffer->capacity = new_capacity; } } /* Push a cstring to buffer */ void janet_buffer_push_cstring(JanetBuffer *buffer, const char *cstring) { int32_t len = (int32_t) strlen(cstring); janet_buffer_push_bytes(buffer, (const uint8_t *) cstring, len); } /* Push multiple bytes into the buffer */ void janet_buffer_push_bytes(JanetBuffer *buffer, const uint8_t *string, int32_t length) { if (0 == length) return; janet_buffer_extra(buffer, length); memcpy(buffer->data + buffer->count, string, length); buffer->count += length; } void janet_buffer_push_string(JanetBuffer *buffer, const uint8_t *string) { janet_buffer_push_bytes(buffer, string, janet_string_length(string)); } /* Push a single byte to the buffer */ void janet_buffer_push_u8(JanetBuffer *buffer, uint8_t byte) { janet_buffer_extra(buffer, 1); buffer->data[buffer->count] = byte; buffer->count++; } /* Push a 16 bit unsigned integer to the buffer */ void janet_buffer_push_u16(JanetBuffer *buffer, uint16_t x) { janet_buffer_extra(buffer, 2); buffer->data[buffer->count] = x & 0xFF; buffer->data[buffer->count + 1] = (x >> 8) & 0xFF; buffer->count += 2; } /* Push a 32 bit unsigned integer to the buffer */ void janet_buffer_push_u32(JanetBuffer *buffer, uint32_t x) { janet_buffer_extra(buffer, 4); buffer->data[buffer->count] = x & 0xFF; buffer->data[buffer->count + 1] = (x >> 8) & 0xFF; buffer->data[buffer->count + 2] = (x >> 16) & 0xFF; buffer->data[buffer->count + 3] = (x >> 24) & 0xFF; buffer->count += 4; } /* Push a 64 bit unsigned integer to the buffer */ void janet_buffer_push_u64(JanetBuffer *buffer, uint64_t x) { janet_buffer_extra(buffer, 8); buffer->data[buffer->count] = x & 0xFF; buffer->data[buffer->count + 1] = (x >> 8) & 0xFF; buffer->data[buffer->count + 2] = (x >> 16) & 0xFF; buffer->data[buffer->count + 3] = (x >> 24) & 0xFF; buffer->data[buffer->count + 4] = (x >> 32) & 0xFF; buffer->data[buffer->count + 5] = (x >> 40) & 0xFF; buffer->data[buffer->count + 6] = (x >> 48) & 0xFF; buffer->data[buffer->count + 7] = (x >> 56) & 0xFF; buffer->count += 8; } /* C functions */ JANET_CORE_FN(cfun_buffer_new, "(buffer/new capacity)", "Creates a new, empty buffer with enough backing memory for `capacity` bytes. " "Returns a new buffer of length 0.") { janet_fixarity(argc, 1); int32_t cap = janet_getinteger(argv, 0); JanetBuffer *buffer = janet_buffer(cap); return janet_wrap_buffer(buffer); } JANET_CORE_FN(cfun_buffer_new_filled, "(buffer/new-filled count &opt byte)", "Creates a new buffer of length `count` filled with `byte`. By default, `byte` is 0. " "Returns the new buffer.") { janet_arity(argc, 1, 2); int32_t count = janet_getinteger(argv, 0); if (count < 0) count = 0; int32_t byte = 0; if (argc == 2) { byte = janet_getinteger(argv, 1) & 0xFF; } JanetBuffer *buffer = janet_buffer(count); if (buffer->data && count > 0) memset(buffer->data, byte, count); buffer->count = count; return janet_wrap_buffer(buffer); } JANET_CORE_FN(cfun_buffer_frombytes, "(buffer/from-bytes & byte-vals)", "Creates a buffer from integer parameters with byte values. All integers " "will be coerced to the range of 1 byte 0-255.") { int32_t i; JanetBuffer *buffer = janet_buffer(argc); for (i = 0; i < argc; i++) { int32_t c = janet_getinteger(argv, i); buffer->data[i] = c & 0xFF; } buffer->count = argc; return janet_wrap_buffer(buffer); } JANET_CORE_FN(cfun_buffer_fill, "(buffer/fill buffer &opt byte)", "Fill up a buffer with bytes, defaulting to 0s. Does not change the buffer's length. " "Returns the modified buffer.") { janet_arity(argc, 1, 2); JanetBuffer *buffer = janet_getbuffer(argv, 0); int32_t byte = 0; if (argc == 2) { byte = janet_getinteger(argv, 1) & 0xFF; } if (buffer->count) { memset(buffer->data, byte, buffer->count); } return argv[0]; } JANET_CORE_FN(cfun_buffer_trim, "(buffer/trim buffer)", "Set the backing capacity of the buffer to the current length of the buffer. Returns the " "modified buffer.") { janet_fixarity(argc, 1); JanetBuffer *buffer = janet_getbuffer(argv, 0); janet_buffer_can_realloc(buffer); if (buffer->count < buffer->capacity) { int32_t newcap = buffer->count > 4 ? buffer->count : 4; uint8_t *newData = janet_realloc(buffer->data, newcap); if (NULL == newData) { JANET_OUT_OF_MEMORY; } buffer->data = newData; buffer->capacity = newcap; } return argv[0]; } JANET_CORE_FN(cfun_buffer_u8, "(buffer/push-byte buffer & xs)", "Append bytes to a buffer. Will expand the buffer as necessary. " "Returns the modified buffer. Will throw an error if the buffer overflows.") { int32_t i; janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); for (i = 1; i < argc; i++) { janet_buffer_push_u8(buffer, (uint8_t)(janet_getinteger(argv, i) & 0xFF)); } return argv[0]; } JANET_CORE_FN(cfun_buffer_word, "(buffer/push-word buffer & xs)", "Append machine words to a buffer. The 4 bytes of the integer are appended " "in twos complement, little endian order, unsigned for all x. Returns the modified buffer. Will " "throw an error if the buffer overflows.") { int32_t i; janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); for (i = 1; i < argc; i++) { double number = janet_getnumber(argv, i); uint32_t word = (uint32_t) number; if (word != number) janet_panicf("cannot convert %v to machine word", argv[i]); janet_buffer_push_u32(buffer, word); } return argv[0]; } JANET_CORE_FN(cfun_buffer_chars, "(buffer/push-string buffer & xs)", "Push byte sequences onto the end of a buffer. " "Will accept any of strings, keywords, symbols, and buffers. " "Returns the modified buffer. " "Will throw an error if the buffer overflows.") { int32_t i; janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); for (i = 1; i < argc; i++) { JanetByteView view = janet_getbytes(argv, i); if (view.bytes == buffer->data) { janet_buffer_ensure(buffer, buffer->count + view.len, 2); view.bytes = buffer->data; } janet_buffer_push_bytes(buffer, view.bytes, view.len); } return argv[0]; } static int should_reverse_bytes(const Janet *argv, int32_t argc) { JanetKeyword order_kw = janet_getkeyword(argv, argc); if (!janet_cstrcmp(order_kw, "le")) { #if JANET_BIG_ENDIAN return 1; #endif } else if (!janet_cstrcmp(order_kw, "be")) { #if JANET_LITTLE_ENDIAN return 1; #endif } else if (!janet_cstrcmp(order_kw, "native")) { return 0; } else { janet_panicf("expected endianness :le, :be or :native, got %v", argv[1]); } return 0; } static void reverse_u32(uint8_t bytes[4]) { uint8_t temp; temp = bytes[3]; bytes[3] = bytes[0]; bytes[0] = temp; temp = bytes[2]; bytes[2] = bytes[1]; bytes[1] = temp; } static void reverse_u64(uint8_t bytes[8]) { uint8_t temp; temp = bytes[7]; bytes[7] = bytes[0]; bytes[0] = temp; temp = bytes[6]; bytes[6] = bytes[1]; bytes[1] = temp; temp = bytes[5]; bytes[5] = bytes[2]; bytes[2] = temp; temp = bytes[4]; bytes[4] = bytes[3]; bytes[3] = temp; } JANET_CORE_FN(cfun_buffer_push_uint16, "(buffer/push-uint16 buffer order data)", "Push a 16 bit unsigned integer data onto the end of the buffer. " "Returns the modified buffer.") { janet_fixarity(argc, 3); JanetBuffer *buffer = janet_getbuffer(argv, 0); int reverse = should_reverse_bytes(argv, 1); uint16_t data = janet_getuinteger16(argv, 2); uint8_t bytes[sizeof(data)]; memcpy(bytes, &data, sizeof(bytes)); if (reverse) { uint8_t temp = bytes[1]; bytes[1] = bytes[0]; bytes[0] = temp; } janet_buffer_push_bytes(buffer, bytes, sizeof(bytes)); return argv[0]; } JANET_CORE_FN(cfun_buffer_push_uint32, "(buffer/push-uint32 buffer order data)", "Push a 32 bit unsigned integer data onto the end of the buffer. " "Returns the modified buffer.") { janet_fixarity(argc, 3); JanetBuffer *buffer = janet_getbuffer(argv, 0); int reverse = should_reverse_bytes(argv, 1); uint32_t data = janet_getuinteger(argv, 2); uint8_t bytes[sizeof(data)]; memcpy(bytes, &data, sizeof(bytes)); if (reverse) reverse_u32(bytes); janet_buffer_push_bytes(buffer, bytes, sizeof(bytes)); return argv[0]; } JANET_CORE_FN(cfun_buffer_push_uint64, "(buffer/push-uint64 buffer order data)", "Push a 64 bit unsigned integer data onto the end of the buffer. " "Returns the modified buffer.") { janet_fixarity(argc, 3); JanetBuffer *buffer = janet_getbuffer(argv, 0); int reverse = should_reverse_bytes(argv, 1); uint64_t data = janet_getuinteger64(argv, 2); uint8_t bytes[sizeof(data)]; memcpy(bytes, &data, sizeof(bytes)); if (reverse) reverse_u64(bytes); janet_buffer_push_bytes(buffer, bytes, sizeof(bytes)); return argv[0]; } JANET_CORE_FN(cfun_buffer_push_float32, "(buffer/push-float32 buffer order data)", "Push the underlying bytes of a 32 bit float data onto the end of the buffer. " "Returns the modified buffer.") { janet_fixarity(argc, 3); JanetBuffer *buffer = janet_getbuffer(argv, 0); int reverse = should_reverse_bytes(argv, 1); float data = (float) janet_getnumber(argv, 2); uint8_t bytes[sizeof(data)]; memcpy(bytes, &data, sizeof(bytes)); if (reverse) reverse_u32(bytes); janet_buffer_push_bytes(buffer, bytes, sizeof(bytes)); return argv[0]; } JANET_CORE_FN(cfun_buffer_push_float64, "(buffer/push-float64 buffer order data)", "Push the underlying bytes of a 64 bit float data onto the end of the buffer. " "Returns the modified buffer.") { janet_fixarity(argc, 3); JanetBuffer *buffer = janet_getbuffer(argv, 0); int reverse = should_reverse_bytes(argv, 1); double data = janet_getnumber(argv, 2); uint8_t bytes[sizeof(data)]; memcpy(bytes, &data, sizeof(bytes)); if (reverse) reverse_u64(bytes); janet_buffer_push_bytes(buffer, bytes, sizeof(bytes)); return argv[0]; } static void buffer_push_impl(JanetBuffer *buffer, Janet *argv, int32_t argc_offset, int32_t argc) { for (int32_t i = argc_offset; i < argc; i++) { if (janet_checktype(argv[i], JANET_NUMBER)) { janet_buffer_push_u8(buffer, (uint8_t)(janet_getinteger(argv, i) & 0xFF)); } else { JanetByteView view = janet_getbytes(argv, i); if (view.bytes == buffer->data) { janet_buffer_ensure(buffer, buffer->count + view.len, 2); view.bytes = buffer->data; } janet_buffer_push_bytes(buffer, view.bytes, view.len); } } } JANET_CORE_FN(cfun_buffer_push_at, "(buffer/push-at buffer index & xs)", "Same as buffer/push, but copies the new data into the buffer " " at index `index`.") { janet_arity(argc, 2, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); int32_t index = janet_getinteger(argv, 1); int32_t old_count = buffer->count; if (index < 0 || index > old_count) { janet_panicf("index out of range [0, %d)", old_count); } buffer->count = index; buffer_push_impl(buffer, argv, 2, argc); if (buffer->count < old_count) { buffer->count = old_count; } return argv[0]; } JANET_CORE_FN(cfun_buffer_push, "(buffer/push buffer & xs)", "Push both individual bytes and byte sequences to a buffer. For each x in xs, " "push the byte if x is an integer, otherwise push the bytesequence to the buffer. " "Thus, this function behaves like both `buffer/push-string` and `buffer/push-byte`. " "Returns the modified buffer. " "Will throw an error if the buffer overflows.") { janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); buffer_push_impl(buffer, argv, 1, argc); return argv[0]; } JANET_CORE_FN(cfun_buffer_clear, "(buffer/clear buffer)", "Sets the size of a buffer to 0 and empties it. The buffer retains " "its memory so it can be efficiently refilled. Returns the modified buffer.") { janet_fixarity(argc, 1); JanetBuffer *buffer = janet_getbuffer(argv, 0); buffer->count = 0; return argv[0]; } JANET_CORE_FN(cfun_buffer_popn, "(buffer/popn buffer n)", "Removes the last `n` bytes from the buffer. Returns the modified buffer.") { janet_fixarity(argc, 2); JanetBuffer *buffer = janet_getbuffer(argv, 0); int32_t n = janet_getinteger(argv, 1); if (n < 0) janet_panic("n must be non-negative"); if (buffer->count < n) { buffer->count = 0; } else { buffer->count -= n; } return argv[0]; } JANET_CORE_FN(cfun_buffer_slice, "(buffer/slice bytes &opt start end)", "Takes a slice of a byte sequence from `start` to `end`. The range is half open, " "[start, end). Indexes can also be negative, indicating indexing from the end of the " "end of the array. By default, `start` is 0 and `end` is the length of the buffer. " "Returns a new buffer.") { JanetByteView view = janet_getbytes(argv, 0); JanetRange range = janet_getslice(argc, argv); JanetBuffer *buffer = janet_buffer(range.end - range.start); if (buffer->data) memcpy(buffer->data, view.bytes + range.start, range.end - range.start); buffer->count = range.end - range.start; return janet_wrap_buffer(buffer); } static void bitloc(int32_t argc, Janet *argv, JanetBuffer **b, int32_t *index, int *bit) { janet_fixarity(argc, 2); JanetBuffer *buffer = janet_getbuffer(argv, 0); double x = janet_getnumber(argv, 1); int64_t bitindex = (int64_t) x; int64_t byteindex = bitindex >> 3; int which_bit = bitindex & 7; if (bitindex != x || bitindex < 0 || byteindex >= buffer->count) janet_panicf("invalid bit index %v", argv[1]); *b = buffer; *index = (int32_t) byteindex; *bit = which_bit; } JANET_CORE_FN(cfun_buffer_bitset, "(buffer/bit-set buffer index)", "Sets the bit at the given bit-index. Returns the buffer.") { int bit; int32_t index; JanetBuffer *buffer; bitloc(argc, argv, &buffer, &index, &bit); buffer->data[index] |= 1 << bit; return argv[0]; } JANET_CORE_FN(cfun_buffer_bitclear, "(buffer/bit-clear buffer index)", "Clears the bit at the given bit-index. Returns the buffer.") { int bit; int32_t index; JanetBuffer *buffer; bitloc(argc, argv, &buffer, &index, &bit); buffer->data[index] &= ~(1 << bit); return argv[0]; } JANET_CORE_FN(cfun_buffer_bitget, "(buffer/bit buffer index)", "Gets the bit at the given bit-index. Returns true if the bit is set, false if not.") { int bit; int32_t index; JanetBuffer *buffer; bitloc(argc, argv, &buffer, &index, &bit); return janet_wrap_boolean(buffer->data[index] & (1 << bit)); } JANET_CORE_FN(cfun_buffer_bittoggle, "(buffer/bit-toggle buffer index)", "Toggles the bit at the given bit index in buffer. Returns the buffer.") { int bit; int32_t index; JanetBuffer *buffer; bitloc(argc, argv, &buffer, &index, &bit); buffer->data[index] ^= (1 << bit); return argv[0]; } JANET_CORE_FN(cfun_buffer_blit, "(buffer/blit dest src &opt dest-start src-start src-end)", "Insert the contents of `src` into `dest`. Can optionally take indices that " "indicate which part of `src` to copy into which part of `dest`. Indices can be " "negative in order to index from the end of `src` or `dest`. Returns `dest`.") { janet_arity(argc, 2, 5); JanetBuffer *dest = janet_getbuffer(argv, 0); JanetByteView src = janet_getbytes(argv, 1); int same_buf = src.bytes == dest->data; int32_t offset_dest = 0; int32_t offset_src = 0; if (argc > 2 && !janet_checktype(argv[2], JANET_NIL)) offset_dest = janet_gethalfrange(argv, 2, dest->count, "dest-start"); if (argc > 3 && !janet_checktype(argv[3], JANET_NIL)) offset_src = janet_gethalfrange(argv, 3, src.len, "src-start"); int32_t length_src; if (argc > 4) { int32_t src_end = src.len; if (!janet_checktype(argv[4], JANET_NIL)) src_end = janet_gethalfrange(argv, 4, src.len, "src-end"); length_src = src_end - offset_src; if (length_src < 0) length_src = 0; } else { length_src = src.len - offset_src; } int64_t last = (int64_t) offset_dest + length_src; if (last > INT32_MAX) janet_panic("buffer blit out of range"); int32_t last32 = (int32_t) last; janet_buffer_ensure(dest, last32, 2); if (last32 > dest->count) dest->count = last32; if (length_src) { if (same_buf) { /* janet_buffer_ensure may have invalidated src */ src.bytes = dest->data; memmove(dest->data + offset_dest, src.bytes + offset_src, length_src); } else { memcpy(dest->data + offset_dest, src.bytes + offset_src, length_src); } } return argv[0]; } JANET_CORE_FN(cfun_buffer_format, "(buffer/format buffer format & args)", "Snprintf like functionality for printing values into a buffer. Returns " "the modified buffer.") { janet_arity(argc, 2, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); const char *strfrmt = (const char *) janet_getstring(argv, 1); janet_buffer_format(buffer, strfrmt, 1, argc, argv); return argv[0]; } JANET_CORE_FN(cfun_buffer_format_at, "(buffer/format-at buffer at format & args)", "Snprintf like functionality for printing values into a buffer. Returns " "the modified buffer.") { janet_arity(argc, 2, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); int32_t at = janet_getinteger(argv, 1); if (at < 0) { at += buffer->count + 1; } if (at > buffer->count || at < 0) janet_panicf("expected index at to be in range [0, %d), got %d", buffer->count, at); int32_t oldcount = buffer->count; buffer->count = at; const char *strfrmt = (const char *) janet_getstring(argv, 2); janet_buffer_format(buffer, strfrmt, 2, argc, argv); if (buffer->count < oldcount) { buffer->count = oldcount; } return argv[0]; } void janet_lib_buffer(JanetTable *env) { JanetRegExt buffer_cfuns[] = { JANET_CORE_REG("buffer/new", cfun_buffer_new), JANET_CORE_REG("buffer/new-filled", cfun_buffer_new_filled), JANET_CORE_REG("buffer/from-bytes", cfun_buffer_frombytes), JANET_CORE_REG("buffer/fill", cfun_buffer_fill), JANET_CORE_REG("buffer/trim", cfun_buffer_trim), JANET_CORE_REG("buffer/push-byte", cfun_buffer_u8), JANET_CORE_REG("buffer/push-word", cfun_buffer_word), JANET_CORE_REG("buffer/push-string", cfun_buffer_chars), JANET_CORE_REG("buffer/push-uint16", cfun_buffer_push_uint16), JANET_CORE_REG("buffer/push-uint32", cfun_buffer_push_uint32), JANET_CORE_REG("buffer/push-uint64", cfun_buffer_push_uint64), JANET_CORE_REG("buffer/push-float32", cfun_buffer_push_float32), JANET_CORE_REG("buffer/push-float64", cfun_buffer_push_float64), JANET_CORE_REG("buffer/push", cfun_buffer_push), JANET_CORE_REG("buffer/push-at", cfun_buffer_push_at), JANET_CORE_REG("buffer/popn", cfun_buffer_popn), JANET_CORE_REG("buffer/clear", cfun_buffer_clear), JANET_CORE_REG("buffer/slice", cfun_buffer_slice), JANET_CORE_REG("buffer/bit-set", cfun_buffer_bitset), JANET_CORE_REG("buffer/bit-clear", cfun_buffer_bitclear), JANET_CORE_REG("buffer/bit", cfun_buffer_bitget), JANET_CORE_REG("buffer/bit-toggle", cfun_buffer_bittoggle), JANET_CORE_REG("buffer/blit", cfun_buffer_blit), JANET_CORE_REG("buffer/format", cfun_buffer_format), JANET_CORE_REG("buffer/format-at", cfun_buffer_format_at), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, buffer_cfuns); } janet-1.41.2/src/core/bytecode.c000066400000000000000000000453151514534607600164040ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "gc.h" #include "util.h" #include "regalloc.h" #endif /* Look up table for instructions */ enum JanetInstructionType janet_instructions[JOP_INSTRUCTION_COUNT] = { JINT_0, /* JOP_NOOP, */ JINT_S, /* JOP_ERROR, */ JINT_ST, /* JOP_TYPECHECK, */ JINT_S, /* JOP_RETURN, */ JINT_0, /* JOP_RETURN_NIL, */ JINT_SSI, /* JOP_ADD_IMMEDIATE, */ JINT_SSS, /* JOP_ADD, */ JINT_SSI, /* JOP_SUBTRACT_IMMEDIATE, */ JINT_SSS, /* JOP_SUBTRACT, */ JINT_SSI, /* JOP_MULTIPLY_IMMEDIATE, */ JINT_SSS, /* JOP_MULTIPLY, */ JINT_SSI, /* JOP_DIVIDE_IMMEDIATE, */ JINT_SSS, /* JOP_DIVIDE, */ JINT_SSS, /* JOP_DIVIDE_FLOOR */ JINT_SSS, /* JOP_MODULO, */ JINT_SSS, /* JOP_REMAINDER, */ JINT_SSS, /* JOP_BAND, */ JINT_SSS, /* JOP_BOR, */ JINT_SSS, /* JOP_BXOR, */ JINT_SS, /* JOP_BNOT, */ JINT_SSS, /* JOP_SHIFT_LEFT, */ JINT_SSI, /* JOP_SHIFT_LEFT_IMMEDIATE, */ JINT_SSS, /* JOP_SHIFT_RIGHT, */ JINT_SSI, /* JOP_SHIFT_RIGHT_IMMEDIATE, */ JINT_SSS, /* JOP_SHIFT_RIGHT_UNSIGNED, */ JINT_SSU, /* JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE, */ JINT_SS, /* JOP_MOVE_FAR, */ JINT_SS, /* JOP_MOVE_NEAR, */ JINT_L, /* JOP_JUMP, */ JINT_SL, /* JOP_JUMP_IF, */ JINT_SL, /* JOP_JUMP_IF_NOT, */ JINT_SL, /* JOP_JUMP_IF_NIL, */ JINT_SL, /* JOP_JUMP_IF_NOT_NIL, */ JINT_SSS, /* JOP_GREATER_THAN, */ JINT_SSI, /* JOP_GREATER_THAN_IMMEDIATE, */ JINT_SSS, /* JOP_LESS_THAN, */ JINT_SSI, /* JOP_LESS_THAN_IMMEDIATE, */ JINT_SSS, /* JOP_EQUALS, */ JINT_SSI, /* JOP_EQUALS_IMMEDIATE, */ JINT_SSS, /* JOP_COMPARE, */ JINT_S, /* JOP_LOAD_NIL, */ JINT_S, /* JOP_LOAD_TRUE, */ JINT_S, /* JOP_LOAD_FALSE, */ JINT_SI, /* JOP_LOAD_INTEGER, */ JINT_SC, /* JOP_LOAD_CONSTANT, */ JINT_SES, /* JOP_LOAD_UPVALUE, */ JINT_S, /* JOP_LOAD_SELF, */ JINT_SES, /* JOP_SET_UPVALUE, */ JINT_SD, /* JOP_CLOSURE, */ JINT_S, /* JOP_PUSH, */ JINT_SS, /* JOP_PUSH_2, */ JINT_SSS, /* JOP_PUSH_3, */ JINT_S, /* JOP_PUSH_ARRAY, */ JINT_SS, /* JOP_CALL, */ JINT_S, /* JOP_TAILCALL, */ JINT_SSS, /* JOP_RESUME, */ JINT_SSU, /* JOP_SIGNAL, */ JINT_SSS, /* JOP_PROPAGATE */ JINT_SSS, /* JOP_IN, */ JINT_SSS, /* JOP_GET, */ JINT_SSS, /* JOP_PUT, */ JINT_SSU, /* JOP_GET_INDEX, */ JINT_SSU, /* JOP_PUT_INDEX, */ JINT_SS, /* JOP_LENGTH */ JINT_S, /* JOP_MAKE_ARRAY */ JINT_S, /* JOP_MAKE_BUFFER */ JINT_S, /* JOP_MAKE_STRING */ JINT_S, /* JOP_MAKE_STRUCT */ JINT_S, /* JOP_MAKE_TABLE */ JINT_S, /* JOP_MAKE_TUPLE */ JINT_S, /* JOP_MAKE_BRACKET_TUPLE */ JINT_SSS, /* JOP_GREATER_THAN_EQUAL */ JINT_SSS, /* JOP_LESS_THAN_EQUAL */ JINT_SSS, /* JOP_NEXT */ JINT_SSS, /* JOP_NOT_EQUALS, */ JINT_SSI, /* JOP_NOT_EQUALS_IMMEDIATE, */ JINT_SSS /* JOP_CANCEL, */ }; /* Remove all noops while preserving jumps and debugging information. * Useful as part of a filtering compiler pass. */ void janet_bytecode_remove_noops(JanetFuncDef *def) { /* Get an instruction rewrite map so we can rewrite jumps */ uint32_t *pc_map = janet_smalloc(sizeof(uint32_t) * (1 + def->bytecode_length)); uint32_t new_bytecode_length = 0; for (int32_t i = 0; i < def->bytecode_length; i++) { uint32_t instr = def->bytecode[i]; uint32_t opcode = instr & 0x7F; pc_map[i] = new_bytecode_length; if (opcode != JOP_NOOP) { new_bytecode_length++; } } pc_map[def->bytecode_length] = new_bytecode_length; /* Linear scan rewrite bytecode and sourcemap. Also fix jumps. */ int32_t j = 0; for (int32_t i = 0; i < def->bytecode_length; i++) { uint32_t instr = def->bytecode[i]; uint32_t opcode = instr & 0x7F; int32_t old_jump_target = 0; int32_t new_jump_target = 0; switch (opcode) { case JOP_NOOP: continue; case JOP_JUMP: /* relative pc is in DS field of instruction */ old_jump_target = i + (((int32_t)instr) >> 8); new_jump_target = pc_map[old_jump_target]; instr += (uint32_t)(new_jump_target - old_jump_target + (i - j)) << 8; break; case JOP_JUMP_IF: case JOP_JUMP_IF_NIL: case JOP_JUMP_IF_NOT: case JOP_JUMP_IF_NOT_NIL: /* relative pc is in ES field of instruction */ old_jump_target = i + (((int32_t)instr) >> 16); new_jump_target = pc_map[old_jump_target]; instr += (uint32_t)(new_jump_target - old_jump_target + (i - j)) << 16; break; default: break; } def->bytecode[j] = instr; if (def->sourcemap != NULL) { def->sourcemap[j] = def->sourcemap[i]; } j++; } /* Rewrite symbolmap */ for (int32_t i = 0; i < def->symbolmap_length; i++) { JanetSymbolMap *sm = def->symbolmap + i; /* Don't rewrite upvalue mappings */ if (sm->birth_pc < UINT32_MAX) { sm->birth_pc = pc_map[sm->birth_pc]; sm->death_pc = pc_map[sm->death_pc]; } } def->bytecode_length = new_bytecode_length; def->bytecode = janet_realloc(def->bytecode, def->bytecode_length * sizeof(uint32_t)); janet_sfree(pc_map); } /* Remove redundant loads, moves and other instructions if possible and convert them to * noops. Input is assumed valid bytecode. */ void janet_bytecode_movopt(JanetFuncDef *def) { JanetcRegisterAllocator ra; int recur = 1; /* Iterate this until no more instructions can be removed. */ while (recur) { janetc_regalloc_init(&ra); /* Look for slots that have writes but no reads (and aren't in the closure bitset). */ if (def->closure_bitset != NULL) { for (int32_t i = 0; i < def->slotcount; i++) { int32_t index = i >> 5; uint32_t mask = 1U << (((uint32_t) i) & 31); if (def->closure_bitset[index] & mask) { janetc_regalloc_touch(&ra, i); } } } #define AA ((instr >> 8) & 0xFF) #define BB ((instr >> 16) & 0xFF) #define CC (instr >> 24) #define DD (instr >> 8) #define EE (instr >> 16) /* Check reads and writes */ for (int32_t i = 0; i < def->bytecode_length; i++) { uint32_t instr = def->bytecode[i]; switch (instr & 0x7F) { /* Group instructions my how they read from slots */ /* No reads or writes */ default: janet_assert(0, "unhandled instruction"); case JOP_JUMP: case JOP_NOOP: case JOP_RETURN_NIL: /* Write A */ case JOP_LOAD_INTEGER: case JOP_LOAD_CONSTANT: case JOP_LOAD_UPVALUE: case JOP_CLOSURE: /* Write D */ case JOP_LOAD_NIL: case JOP_LOAD_TRUE: case JOP_LOAD_FALSE: case JOP_LOAD_SELF: break; case JOP_MAKE_ARRAY: case JOP_MAKE_BUFFER: case JOP_MAKE_STRING: case JOP_MAKE_STRUCT: case JOP_MAKE_TABLE: case JOP_MAKE_TUPLE: case JOP_MAKE_BRACKET_TUPLE: /* Reads from the stack, don't remove */ janetc_regalloc_touch(&ra, DD); break; /* Read A */ case JOP_ERROR: case JOP_TYPECHECK: case JOP_JUMP_IF: case JOP_JUMP_IF_NOT: case JOP_JUMP_IF_NIL: case JOP_JUMP_IF_NOT_NIL: case JOP_SET_UPVALUE: /* Write E, Read A */ case JOP_MOVE_FAR: janetc_regalloc_touch(&ra, AA); break; /* Read B */ case JOP_SIGNAL: /* Write A, Read B */ case JOP_ADD_IMMEDIATE: case JOP_SUBTRACT_IMMEDIATE: case JOP_MULTIPLY_IMMEDIATE: case JOP_DIVIDE_IMMEDIATE: case JOP_SHIFT_LEFT_IMMEDIATE: case JOP_SHIFT_RIGHT_IMMEDIATE: case JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE: case JOP_GREATER_THAN_IMMEDIATE: case JOP_LESS_THAN_IMMEDIATE: case JOP_EQUALS_IMMEDIATE: case JOP_NOT_EQUALS_IMMEDIATE: case JOP_GET_INDEX: janetc_regalloc_touch(&ra, BB); break; /* Read D */ case JOP_RETURN: case JOP_PUSH: case JOP_PUSH_ARRAY: case JOP_TAILCALL: janetc_regalloc_touch(&ra, DD); break; /* Write A, Read E */ case JOP_MOVE_NEAR: case JOP_LENGTH: case JOP_BNOT: case JOP_CALL: janetc_regalloc_touch(&ra, EE); break; /* Read A, B */ case JOP_PUT_INDEX: janetc_regalloc_touch(&ra, AA); janetc_regalloc_touch(&ra, BB); break; /* Read A, E */ case JOP_PUSH_2: janetc_regalloc_touch(&ra, AA); janetc_regalloc_touch(&ra, EE); break; /* Read B, C */ case JOP_PROPAGATE: /* Write A, Read B and C */ case JOP_BAND: case JOP_BOR: case JOP_BXOR: case JOP_ADD: case JOP_SUBTRACT: case JOP_MULTIPLY: case JOP_DIVIDE: case JOP_DIVIDE_FLOOR: case JOP_MODULO: case JOP_REMAINDER: case JOP_SHIFT_LEFT: case JOP_SHIFT_RIGHT: case JOP_SHIFT_RIGHT_UNSIGNED: case JOP_GREATER_THAN: case JOP_LESS_THAN: case JOP_EQUALS: case JOP_COMPARE: case JOP_IN: case JOP_GET: case JOP_GREATER_THAN_EQUAL: case JOP_LESS_THAN_EQUAL: case JOP_NOT_EQUALS: case JOP_CANCEL: case JOP_RESUME: case JOP_NEXT: janetc_regalloc_touch(&ra, BB); janetc_regalloc_touch(&ra, CC); break; /* Read A, B, C */ case JOP_PUT: case JOP_PUSH_3: janetc_regalloc_touch(&ra, AA); janetc_regalloc_touch(&ra, BB); janetc_regalloc_touch(&ra, CC); break; } } /* Iterate and set noops on instructions that make writes that no one ever reads. * Only set noops for instructions with no side effects - moves, loads, etc. that can't * raise errors (outside of systemic errors like oom or stack overflow). */ recur = 0; for (int32_t i = 0; i < def->bytecode_length; i++) { uint32_t instr = def->bytecode[i]; switch (instr & 0x7F) { default: break; /* Write D */ case JOP_LOAD_NIL: case JOP_LOAD_TRUE: case JOP_LOAD_FALSE: case JOP_LOAD_SELF: case JOP_MAKE_ARRAY: case JOP_MAKE_TUPLE: case JOP_MAKE_BRACKET_TUPLE: { if (!janetc_regalloc_check(&ra, DD)) { def->bytecode[i] = JOP_NOOP; recur = 1; } } break; /* Write E, Read A */ case JOP_MOVE_FAR: { if (!janetc_regalloc_check(&ra, EE)) { def->bytecode[i] = JOP_NOOP; recur = 1; } } break; /* Write A, Read E */ case JOP_MOVE_NEAR: /* Write A, Read B */ case JOP_GET_INDEX: /* Write A */ case JOP_LOAD_INTEGER: case JOP_LOAD_CONSTANT: case JOP_LOAD_UPVALUE: case JOP_CLOSURE: { if (!janetc_regalloc_check(&ra, AA)) { def->bytecode[i] = JOP_NOOP; recur = 1; } } break; } } janetc_regalloc_deinit(&ra); #undef AA #undef BB #undef CC #undef DD #undef EE } } /* Verify some bytecode */ int janet_verify(JanetFuncDef *def) { int vargs = !!(def->flags & JANET_FUNCDEF_FLAG_VARARG); int32_t i; int32_t maxslot = def->arity + vargs; int32_t sc = def->slotcount; if (def->bytecode_length == 0) return 1; if (maxslot > sc) return 2; /* Verify each instruction */ for (i = 0; i < def->bytecode_length; i++) { uint32_t instr = def->bytecode[i]; /* Check for invalid instructions */ if ((instr & 0x7F) >= JOP_INSTRUCTION_COUNT) { return 3; } enum JanetInstructionType type = janet_instructions[instr & 0x7F]; switch (type) { case JINT_0: continue; case JINT_S: { if ((int32_t)(instr >> 8) >= sc) return 4; continue; } case JINT_SI: case JINT_SU: case JINT_ST: { if ((int32_t)((instr >> 8) & 0xFF) >= sc) return 4; continue; } case JINT_L: { int32_t jumpdest = i + (((int32_t)instr) >> 8); if (jumpdest < 0 || jumpdest >= def->bytecode_length) return 5; continue; } case JINT_SS: { if ((int32_t)((instr >> 8) & 0xFF) >= sc || (int32_t)(instr >> 16) >= sc) return 4; continue; } case JINT_SSI: case JINT_SSU: { if ((int32_t)((instr >> 8) & 0xFF) >= sc || (int32_t)((instr >> 16) & 0xFF) >= sc) return 4; continue; } case JINT_SL: { int32_t jumpdest = i + (((int32_t)instr) >> 16); if ((int32_t)((instr >> 8) & 0xFF) >= sc) return 4; if (jumpdest < 0 || jumpdest >= def->bytecode_length) return 5; continue; } case JINT_SSS: { if (((int32_t)(instr >> 8) & 0xFF) >= sc || ((int32_t)(instr >> 16) & 0xFF) >= sc || ((int32_t)(instr >> 24) & 0xFF) >= sc) return 4; continue; } case JINT_SD: { if ((int32_t)((instr >> 8) & 0xFF) >= sc) return 4; if ((int32_t)(instr >> 16) >= def->defs_length) return 6; continue; } case JINT_SC: { if ((int32_t)((instr >> 8) & 0xFF) >= sc) return 4; if ((int32_t)(instr >> 16) >= def->constants_length) return 7; continue; } case JINT_SES: { /* How can we check the last slot index? We need info parent funcdefs. Resort * to runtime checks for now. Maybe invalid upvalue references could be defaulted * to nil? (don't commit to this in the long term, though) */ if ((int32_t)((instr >> 8) & 0xFF) >= sc) return 4; if ((int32_t)((instr >> 16) & 0xFF) >= def->environments_length) return 8; continue; } } } /* Verify last instruction is either a jump, return, return-nil, or tailcall. Eventually, * some real flow analysis would be ideal, but this should be very effective. Will completely * prevent running over the end of bytecode. However, valid functions with dead code will * be rejected. */ { uint32_t lastop = def->bytecode[def->bytecode_length - 1] & 0xFF; switch (lastop) { default: return 9; case JOP_RETURN: case JOP_RETURN_NIL: case JOP_JUMP: case JOP_ERROR: case JOP_TAILCALL: break; } } return 0; } /* Allocate an empty funcdef. This function may have added functionality * as commonalities between asm and compile arise. */ JanetFuncDef *janet_funcdef_alloc(void) { JanetFuncDef *def = janet_gcalloc(JANET_MEMORY_FUNCDEF, sizeof(JanetFuncDef)); def->environments = NULL; def->constants = NULL; def->bytecode = NULL; def->closure_bitset = NULL; def->flags = 0; def->slotcount = 0; def->symbolmap = NULL; def->arity = 0; def->min_arity = 0; def->max_arity = INT32_MAX; def->source = NULL; def->sourcemap = NULL; def->name = NULL; def->defs = NULL; def->defs_length = 0; def->constants_length = 0; def->bytecode_length = 0; def->environments_length = 0; def->symbolmap_length = 0; def->named_args_count = 0; return def; } /* Create a simple closure from a funcdef */ JanetFunction *janet_thunk(JanetFuncDef *def) { JanetFunction *func = janet_gcalloc(JANET_MEMORY_FUNCTION, sizeof(JanetFunction)); func->def = def; janet_assert(def->environments_length == 0, "tried to create thunk that needs upvalues"); return func; } janet-1.41.2/src/core/capi.c000066400000000000000000000500711514534607600155150ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "state.h" #include "fiber.h" #include "util.h" #endif #ifndef JANET_SINGLE_THREADED #ifndef JANET_WINDOWS #include #endif #endif #ifdef JANET_WINDOWS #include #endif #ifdef JANET_USE_STDATOMIC #include /* We don't need stdatomic on most compilers since we use compiler builtins for atomic operations. * Some (TCC), explicitly require using stdatomic.h and don't have any exposed builtins (that I know of). * For TCC and similar compilers, one would need -std=c11 or similar then to get access. */ #endif JANET_NO_RETURN static void janet_top_level_signal(const char *msg) { #ifdef JANET_TOP_LEVEL_SIGNAL JANET_TOP_LEVEL_SIGNAL(msg); #else fputs(msg, stdout); # ifdef JANET_SINGLE_THREADED exit(-1); # elif defined(JANET_WINDOWS) ExitThread(-1); # else pthread_exit(NULL); # endif #endif } void janet_signalv(JanetSignal sig, Janet message) { if (janet_vm.return_reg != NULL) { /* Should match logic in janet_call for coercing everything not ok to an error (no awaits, yields, etc.) */ if (janet_vm.coerce_error && sig != JANET_SIGNAL_OK) { #ifdef JANET_EV if (NULL != janet_vm.root_fiber && sig == JANET_SIGNAL_EVENT) { janet_vm.root_fiber->sched_id++; } #endif if (sig != JANET_SIGNAL_ERROR) { message = janet_wrap_string(janet_formatc("%v coerced from %s to error", message, janet_signal_names[sig])); } sig = JANET_SIGNAL_ERROR; } *janet_vm.return_reg = message; if (NULL != janet_vm.fiber) { janet_vm.fiber->flags |= JANET_FIBER_DID_LONGJUMP; } #if defined(JANET_BSD) || defined(JANET_APPLE) _longjmp(*janet_vm.signal_buf, sig); #else longjmp(*janet_vm.signal_buf, sig); #endif } else { const char *str = (const char *)janet_formatc("janet top level signal - %v\n", message); janet_top_level_signal(str); } } void janet_panicv(Janet message) { janet_signalv(JANET_SIGNAL_ERROR, message); } void janet_panicf(const char *format, ...) { va_list args; const uint8_t *ret; JanetBuffer buffer; int32_t len = 0; while (format[len]) len++; janet_buffer_init(&buffer, len); va_start(args, format); janet_formatbv(&buffer, format, args); va_end(args); ret = janet_string(buffer.data, buffer.count); janet_buffer_deinit(&buffer); janet_panics(ret); } void janet_panic(const char *message) { janet_panicv(janet_cstringv(message)); } void janet_panics(const uint8_t *message) { janet_panicv(janet_wrap_string(message)); } void janet_panic_type(Janet x, int32_t n, int expected) { janet_panicf("bad slot #%d, expected %T, got %v", n, expected, x); } void janet_panic_abstract(Janet x, int32_t n, const JanetAbstractType *at) { janet_panicf("bad slot #%d, expected %s, got %v", n, at->name, x); } void janet_fixarity(int32_t arity, int32_t fix) { if (arity != fix) janet_panicf("arity mismatch, expected %d, got %d", fix, arity); } void janet_arity(int32_t arity, int32_t min, int32_t max) { if (min >= 0 && arity < min) janet_panicf("arity mismatch, expected at least %d, got %d", min, arity); if (max >= 0 && arity > max) janet_panicf("arity mismatch, expected at most %d, got %d", max, arity); } #define DEFINE_GETTER(name, NAME, type) \ type janet_get##name(const Janet *argv, int32_t n) { \ Janet x = argv[n]; \ if (!janet_checktype(x, JANET_##NAME)) { \ janet_panic_type(x, n, JANET_TFLAG_##NAME); \ } \ return janet_unwrap_##name(x); \ } #define DEFINE_OPT(name, NAME, type) \ type janet_opt##name(const Janet *argv, int32_t argc, int32_t n, type dflt) { \ if (n >= argc) return dflt; \ if (janet_checktype(argv[n], JANET_NIL)) return dflt; \ return janet_get##name(argv, n); \ } #define DEFINE_OPTLEN(name, NAME, type) \ type janet_opt##name(const Janet *argv, int32_t argc, int32_t n, int32_t dflt_len) { \ if (n >= argc || janet_checktype(argv[n], JANET_NIL)) {\ return janet_##name(dflt_len); \ }\ return janet_get##name(argv, n); \ } int janet_getmethod(const uint8_t *method, const JanetMethod *methods, Janet *out) { while (methods->name) { if (!janet_cstrcmp(method, methods->name)) { *out = janet_wrap_cfunction(methods->cfun); return 1; } methods++; } return 0; } Janet janet_nextmethod(const JanetMethod *methods, Janet key) { if (!janet_checktype(key, JANET_NIL)) { while (methods->name) { if (janet_keyeq(key, methods->name)) { methods++; break; } methods++; } } if (methods->name) { return janet_ckeywordv(methods->name); } else { return janet_wrap_nil(); } } DEFINE_GETTER(number, NUMBER, double) DEFINE_GETTER(array, ARRAY, JanetArray *) DEFINE_GETTER(tuple, TUPLE, const Janet *) DEFINE_GETTER(table, TABLE, JanetTable *) DEFINE_GETTER(struct, STRUCT, const JanetKV *) DEFINE_GETTER(string, STRING, const uint8_t *) DEFINE_GETTER(keyword, KEYWORD, const uint8_t *) DEFINE_GETTER(symbol, SYMBOL, const uint8_t *) DEFINE_GETTER(buffer, BUFFER, JanetBuffer *) DEFINE_GETTER(fiber, FIBER, JanetFiber *) DEFINE_GETTER(function, FUNCTION, JanetFunction *) DEFINE_GETTER(cfunction, CFUNCTION, JanetCFunction) DEFINE_GETTER(boolean, BOOLEAN, int) DEFINE_GETTER(pointer, POINTER, void *) DEFINE_OPT(number, NUMBER, double) DEFINE_OPT(tuple, TUPLE, const Janet *) DEFINE_OPT(struct, STRUCT, const JanetKV *) DEFINE_OPT(string, STRING, const uint8_t *) DEFINE_OPT(keyword, KEYWORD, const uint8_t *) DEFINE_OPT(symbol, SYMBOL, const uint8_t *) DEFINE_OPT(fiber, FIBER, JanetFiber *) DEFINE_OPT(function, FUNCTION, JanetFunction *) DEFINE_OPT(cfunction, CFUNCTION, JanetCFunction) DEFINE_OPT(boolean, BOOLEAN, int) DEFINE_OPT(pointer, POINTER, void *) DEFINE_OPTLEN(buffer, BUFFER, JanetBuffer *) DEFINE_OPTLEN(table, TABLE, JanetTable *) DEFINE_OPTLEN(array, ARRAY, JanetArray *) const char *janet_optcstring(const Janet *argv, int32_t argc, int32_t n, const char *dflt) { if (n >= argc || janet_checktype(argv[n], JANET_NIL)) { return dflt; } return janet_getcstring(argv, n); } #undef DEFINE_GETTER #undef DEFINE_OPT #undef DEFINE_OPTLEN const char *janet_getcstring(const Janet *argv, int32_t n) { if (!janet_checktype(argv[n], JANET_STRING)) { janet_panic_type(argv[n], n, JANET_TFLAG_STRING); } return janet_getcbytes(argv, n); } const char *janet_getcbytes(const Janet *argv, int32_t n) { /* Ensure buffer 0-padded */ if (janet_checktype(argv[n], JANET_BUFFER)) { JanetBuffer *b = janet_unwrap_buffer(argv[n]); if ((b->gc.flags & JANET_BUFFER_FLAG_NO_REALLOC) && b->count == b->capacity) { /* Make a copy with janet_smalloc in the rare case we have a buffer that * cannot be realloced and pushing a 0 byte would panic. */ char *new_string = janet_smalloc(b->count + 1); memcpy(new_string, b->data, b->count); new_string[b->count] = 0; if (strlen(new_string) != (size_t) b->count) goto badzeros; return new_string; } else { /* Ensure trailing 0 */ janet_buffer_push_u8(b, 0); b->count--; if (strlen((char *)b->data) != (size_t) b->count) goto badzeros; return (const char *) b->data; } } JanetByteView view = janet_getbytes(argv, n); const char *cstr = (const char *)view.bytes; if (strlen(cstr) != (size_t) view.len) goto badzeros; return cstr; badzeros: janet_panic("bytes contain embedded 0s"); } const char *janet_optcbytes(const Janet *argv, int32_t argc, int32_t n, const char *dflt) { if (n >= argc || janet_checktype(argv[n], JANET_NIL)) { return dflt; } return janet_getcbytes(argv, n); } int32_t janet_getnat(const Janet *argv, int32_t n) { Janet x = argv[n]; if (!janet_checkint(x)) goto bad; int32_t ret = janet_unwrap_integer(x); if (ret < 0) goto bad; return ret; bad: janet_panicf("bad slot #%d, expected non-negative 32 bit signed integer, got %v", n, x); } JanetAbstract janet_checkabstract(Janet x, const JanetAbstractType *at) { if (!janet_checktype(x, JANET_ABSTRACT)) return NULL; JanetAbstract a = janet_unwrap_abstract(x); if (janet_abstract_type(a) != at) return NULL; return a; } static int janet_strlike_cmp(JanetType type, Janet x, const char *cstring) { if (janet_type(x) != type) return 0; return !janet_cstrcmp(janet_unwrap_string(x), cstring); } int janet_keyeq(Janet x, const char *cstring) { return janet_strlike_cmp(JANET_KEYWORD, x, cstring); } int janet_streq(Janet x, const char *cstring) { return janet_strlike_cmp(JANET_STRING, x, cstring); } int janet_symeq(Janet x, const char *cstring) { return janet_strlike_cmp(JANET_SYMBOL, x, cstring); } int32_t janet_getinteger(const Janet *argv, int32_t n) { Janet x = argv[n]; if (!janet_checkint(x)) { janet_panicf("bad slot #%d, expected 32 bit signed integer, got %v", n, x); } return janet_unwrap_integer(x); } uint32_t janet_getuinteger(const Janet *argv, int32_t n) { Janet x = argv[n]; if (!janet_checkuint(x)) { janet_panicf("bad slot #%d, expected 32 bit unsigned integer, got %v", n, x); } return (uint32_t) janet_unwrap_number(x); } int16_t janet_getinteger16(const Janet *argv, int32_t n) { Janet x = argv[n]; if (!janet_checkint16(x)) { janet_panicf("bad slot #%d, expected 16 bit signed integer, got %v", n, x); } return (int16_t) janet_unwrap_number(x); } uint16_t janet_getuinteger16(const Janet *argv, int32_t n) { Janet x = argv[n]; if (!janet_checkuint16(x)) { janet_panicf("bad slot #%d, expected 16 bit unsigned integer, got %v", n, x); } return (uint16_t) janet_unwrap_number(x); } int64_t janet_getinteger64(const Janet *argv, int32_t n) { #ifdef JANET_INT_TYPES return janet_unwrap_s64(argv[n]); #else Janet x = argv[n]; if (!janet_checkint64(x)) { janet_panicf("bad slot #%d, expected 64 bit signed integer, got %v", n, x); } return (int64_t) janet_unwrap_number(x); #endif } uint64_t janet_getuinteger64(const Janet *argv, int32_t n) { #ifdef JANET_INT_TYPES return janet_unwrap_u64(argv[n]); #else Janet x = argv[n]; if (!janet_checkuint64(x)) { janet_panicf("bad slot #%d, expected 64 bit unsigned integer, got %v", n, x); } return (uint64_t) janet_unwrap_number(x); #endif } size_t janet_getsize(const Janet *argv, int32_t n) { Janet x = argv[n]; if (!janet_checksize(x)) { janet_panicf("bad slot #%d, expected size, got %v", n, x); } return (size_t) janet_unwrap_number(x); } int32_t janet_gethalfrange(const Janet *argv, int32_t n, int32_t length, const char *which) { int32_t raw = janet_getinteger(argv, n); int32_t not_raw = raw; if (not_raw < 0) not_raw += length + 1; if (not_raw < 0 || not_raw > length) janet_panicf("%s index %d out of range [%d,%d]", which, (int64_t) raw, -(int64_t)length - 1, (int64_t) length); return not_raw; } int32_t janet_getstartrange(const Janet *argv, int32_t argc, int32_t n, int32_t length) { if (n >= argc || janet_checktype(argv[n], JANET_NIL)) { return 0; } return janet_gethalfrange(argv, n, length, "start"); } int32_t janet_getendrange(const Janet *argv, int32_t argc, int32_t n, int32_t length) { if (n >= argc || janet_checktype(argv[n], JANET_NIL)) { return length; } return janet_gethalfrange(argv, n, length, "end"); } int32_t janet_getargindex(const Janet *argv, int32_t n, int32_t length, const char *which) { int32_t raw = janet_getinteger(argv, n); int32_t not_raw = raw; if (not_raw < 0) not_raw += length; if (not_raw < 0 || not_raw > length) janet_panicf("%s index %d out of range [%d,%d)", which, (int64_t)raw, -(int64_t)length, (int64_t)length); return not_raw; } JanetView janet_getindexed(const Janet *argv, int32_t n) { Janet x = argv[n]; JanetView view; if (!janet_indexed_view(x, &view.items, &view.len)) { janet_panic_type(x, n, JANET_TFLAG_INDEXED); } return view; } JanetByteView janet_getbytes(const Janet *argv, int32_t n) { Janet x = argv[n]; JanetByteView view; if (!janet_bytes_view(x, &view.bytes, &view.len)) { janet_panic_type(x, n, JANET_TFLAG_BYTES); } return view; } JanetDictView janet_getdictionary(const Janet *argv, int32_t n) { Janet x = argv[n]; JanetDictView view; if (!janet_dictionary_view(x, &view.kvs, &view.len, &view.cap)) { janet_panic_type(x, n, JANET_TFLAG_DICTIONARY); } return view; } void *janet_getabstract(const Janet *argv, int32_t n, const JanetAbstractType *at) { Janet x = argv[n]; if (!janet_checktype(x, JANET_ABSTRACT)) { janet_panic_abstract(x, n, at); } void *abstractx = janet_unwrap_abstract(x); if (janet_abstract_type(abstractx) != at) { janet_panic_abstract(x, n, at); } return abstractx; } JanetRange janet_getslice(int32_t argc, const Janet *argv) { janet_arity(argc, 1, 3); JanetRange range; int32_t length = janet_length(argv[0]); range.start = janet_getstartrange(argv, argc, 1, length); range.end = janet_getendrange(argv, argc, 2, length); if (range.end < range.start) range.end = range.start; return range; } Janet janet_dyn(const char *name) { if (!janet_vm.fiber) { if (!janet_vm.top_dyns) return janet_wrap_nil(); return janet_table_get(janet_vm.top_dyns, janet_ckeywordv(name)); } if (janet_vm.fiber->env) { return janet_table_get_keyword(janet_vm.fiber->env, name); } else { return janet_wrap_nil(); } } void janet_setdyn(const char *name, Janet value) { if (!janet_vm.fiber) { if (!janet_vm.top_dyns) janet_vm.top_dyns = janet_table(10); janet_table_put(janet_vm.top_dyns, janet_ckeywordv(name), value); } else { if (!janet_vm.fiber->env) { janet_vm.fiber->env = janet_table(1); } janet_table_put(janet_vm.fiber->env, janet_ckeywordv(name), value); } } /* Create a function that when called, returns X. Trivial in Janet, a pain in C. */ JanetFunction *janet_thunk_delay(Janet x) { static const uint32_t bytecode[] = { JOP_LOAD_CONSTANT, JOP_RETURN }; JanetFuncDef *def = janet_funcdef_alloc(); def->arity = 0; def->min_arity = 0; def->max_arity = INT32_MAX; def->flags = JANET_FUNCDEF_FLAG_VARARG; def->slotcount = 1; def->bytecode = janet_malloc(sizeof(bytecode)); def->bytecode_length = (int32_t)(sizeof(bytecode) / sizeof(uint32_t)); def->constants = janet_malloc(sizeof(Janet)); def->constants_length = 1; def->name = NULL; if (!def->bytecode || !def->constants) { JANET_OUT_OF_MEMORY; } def->constants[0] = x; memcpy(def->bytecode, bytecode, sizeof(bytecode)); janet_def_addflags(def); /* janet_verify(def); */ return janet_thunk(def); } uint64_t janet_getflags(const Janet *argv, int32_t n, const char *flags) { uint64_t ret = 0; const uint8_t *keyw = janet_getkeyword(argv, n); int32_t klen = janet_string_length(keyw); int32_t flen = (int32_t) strlen(flags); if (flen > 64) { flen = 64; } for (int32_t j = 0; j < klen; j++) { for (int32_t i = 0; i < flen; i++) { if (((uint8_t) flags[i]) == keyw[j]) { ret |= 1ULL << i; goto found; } } janet_panicf("unexpected flag %c, expected one of \"%s\"", (char) keyw[j], flags); found: ; } return ret; } int32_t janet_optnat(const Janet *argv, int32_t argc, int32_t n, int32_t dflt) { if (argc <= n) return dflt; if (janet_checktype(argv[n], JANET_NIL)) return dflt; return janet_getnat(argv, n); } int32_t janet_optinteger(const Janet *argv, int32_t argc, int32_t n, int32_t dflt) { if (argc <= n) return dflt; if (janet_checktype(argv[n], JANET_NIL)) return dflt; return janet_getinteger(argv, n); } int64_t janet_optinteger64(const Janet *argv, int32_t argc, int32_t n, int64_t dflt) { if (argc <= n) return dflt; if (janet_checktype(argv[n], JANET_NIL)) return dflt; return janet_getinteger64(argv, n); } size_t janet_optsize(const Janet *argv, int32_t argc, int32_t n, size_t dflt) { if (argc <= n) return dflt; if (janet_checktype(argv[n], JANET_NIL)) return dflt; return janet_getsize(argv, n); } void *janet_optabstract(const Janet *argv, int32_t argc, int32_t n, const JanetAbstractType *at, void *dflt) { if (argc <= n) return dflt; if (janet_checktype(argv[n], JANET_NIL)) return dflt; return janet_getabstract(argv, n, at); } uint32_t janet_optuinteger(const Janet *argv, int32_t argc, int32_t n, uint32_t dflt) { if (argc <= n) return dflt; if (janet_checktype(argv[n], JANET_NIL)) return dflt; return janet_getuinteger(argv, n); } uint64_t janet_optuinteger64(const Janet *argv, int32_t argc, int32_t n, uint64_t dflt) { if (argc <= n) return dflt; if (janet_checktype(argv[n], JANET_NIL)) return dflt; return janet_getuinteger64(argv, n); } /* Atomic refcounts */ JanetAtomicInt janet_atomic_inc(JanetAtomicInt volatile *x) { #ifdef _MSC_VER return _InterlockedIncrement(x); #elif defined(JANET_USE_STDATOMIC) return atomic_fetch_add_explicit(x, 1, memory_order_relaxed) + 1; #elif defined(JANET_PLAN9) return aincl((void*)x, 1); #else return __atomic_add_fetch(x, 1, __ATOMIC_RELAXED); #endif } JanetAtomicInt janet_atomic_dec(JanetAtomicInt volatile *x) { #ifdef _MSC_VER return _InterlockedDecrement(x); #elif defined(JANET_USE_STDATOMIC) return atomic_fetch_add_explicit(x, -1, memory_order_acq_rel) - 1; #elif defined(JANET_PLAN9) return aincl((void*)x, -1); #else return __atomic_add_fetch(x, -1, __ATOMIC_ACQ_REL); #endif } JanetAtomicInt janet_atomic_load(JanetAtomicInt volatile *x) { #ifdef _MSC_VER return _InterlockedOr(x, 0); #elif defined(JANET_PLAN9) return agetl((void*)x); #elif defined(JANET_USE_STDATOMIC) return atomic_load_explicit(x, memory_order_acquire); #else return __atomic_load_n(x, __ATOMIC_ACQUIRE); #endif } JanetAtomicInt janet_atomic_load_relaxed(JanetAtomicInt volatile *x) { #ifdef _MSC_VER return _InterlockedOr(x, 0); #elif defined(JANET_PLAN9) return agetl((void*)x); #elif defined(JANET_USE_STDATOMIC) return atomic_load_explicit(x, memory_order_relaxed); #else return __atomic_load_n(x, __ATOMIC_RELAXED); #endif } /* Some definitions for function-like macros */ JANET_API JanetStructHead *(janet_struct_head)(JanetStruct st) { return janet_struct_head(st); } JANET_API JanetAbstractHead *(janet_abstract_head)(const void *abstract) { return janet_abstract_head(abstract); } JANET_API JanetStringHead *(janet_string_head)(JanetString s) { return janet_string_head(s); } JANET_API JanetTupleHead *(janet_tuple_head)(JanetTuple tuple) { return janet_tuple_head(tuple); } janet-1.41.2/src/core/cfuns.c000066400000000000000000000351041514534607600157170ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "compile.h" #include "emit.h" #include "vector.h" #endif static int arity1or2(JanetFopts opts, JanetSlot *args) { (void) opts; int32_t arity = janet_v_count(args); return arity == 1 || arity == 2; } static int arity2or3(JanetFopts opts, JanetSlot *args) { (void) opts; int32_t arity = janet_v_count(args); return arity == 2 || arity == 3; } static int fixarity1(JanetFopts opts, JanetSlot *args) { (void) opts; return janet_v_count(args) == 1; } static int maxarity1(JanetFopts opts, JanetSlot *args) { (void) opts; return janet_v_count(args) <= 1; } static int minarity2(JanetFopts opts, JanetSlot *args) { (void) opts; return janet_v_count(args) >= 2; } static int fixarity2(JanetFopts opts, JanetSlot *args) { (void) opts; return janet_v_count(args) == 2; } static int fixarity3(JanetFopts opts, JanetSlot *args) { (void) opts; return janet_v_count(args) == 3; } /* Generic handling for $A = op $B */ static JanetSlot genericSS(JanetFopts opts, int op, JanetSlot s) { JanetSlot target = janetc_gettarget(opts); janetc_emit_ss(opts.compiler, op, target, s, 1); return target; } /* Generic handling for $A = $B op I */ static JanetSlot genericSSI(JanetFopts opts, int op, JanetSlot s, int32_t imm) { JanetSlot target = janetc_gettarget(opts); janetc_emit_ssi(opts.compiler, op, target, s, imm, 1); return target; } /* Emit an insruction that implements a form by itself. */ static JanetSlot opfunction( JanetFopts opts, JanetSlot *args, int op, Janet defaultArg2) { JanetCompiler *c = opts.compiler; int32_t len; len = janet_v_count(args); JanetSlot t; if (len == 1) { t = janetc_gettarget(opts); janetc_emit_sss(c, op, t, args[0], janetc_cslot(defaultArg2), 1); return t; } else { /* len == 2 */ t = janetc_gettarget(opts); janetc_emit_sss(c, op, t, args[0], args[1], 1); } return t; } /* Check if a value can be coerced to an immediate value */ static int can_be_imm(Janet x, int8_t *out) { if (!janet_checkint(x)) return 0; int32_t integer = janet_unwrap_integer(x); if (integer > INT8_MAX || integer < INT8_MIN) return 0; *out = (int8_t) integer; return 1; } /* Check if a slot can be coerced to an immediate value */ static int can_slot_be_imm(JanetSlot s, int8_t *out) { if (!(s.flags & JANET_SLOT_CONSTANT)) return 0; return can_be_imm(s.constant, out); } /* Emit a series of instructions instead of a function call to a math op */ static JanetSlot opreduce( JanetFopts opts, JanetSlot *args, int op, int opim, Janet nullary, Janet unary) { JanetCompiler *c = opts.compiler; int32_t i, len; int8_t imm = 0; len = janet_v_count(args); JanetSlot t; if (len == 0) { return janetc_cslot(nullary); } else if (len == 1) { t = janetc_gettarget(opts); /* Special case subtract to be times -1 */ if (op == JOP_SUBTRACT) { janetc_emit_ssi(c, JOP_MULTIPLY_IMMEDIATE, t, args[0], -1, 1); } else { janetc_emit_sss(c, op, t, janetc_cslot(unary), args[0], 1); } return t; } t = janetc_gettarget(opts); if (opim && can_slot_be_imm(args[1], &imm)) { janetc_emit_ssi(c, opim, t, args[0], imm, 1); } else { janetc_emit_sss(c, op, t, args[0], args[1], 1); } for (i = 2; i < len; i++) { if (opim && can_slot_be_imm(args[i], &imm)) { janetc_emit_ssi(c, opim, t, t, imm, 1); } else { janetc_emit_sss(c, op, t, t, args[i], 1); } } return t; } /* Function optimizers */ static JanetSlot do_propagate(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_PROPAGATE, 0, janet_wrap_nil(), janet_wrap_nil()); } static JanetSlot do_error(JanetFopts opts, JanetSlot *args) { janetc_emit_s(opts.compiler, JOP_ERROR, args[0], 0); return janetc_cslot(janet_wrap_nil()); } static JanetSlot do_debug(JanetFopts opts, JanetSlot *args) { (void)args; int32_t len = janet_v_count(args); JanetSlot t = janetc_gettarget(opts); janetc_emit_ssu(opts.compiler, JOP_SIGNAL, t, (len == 1) ? args[0] : janetc_cslot(janet_wrap_nil()), JANET_SIGNAL_DEBUG, 1); return t; } static JanetSlot do_in(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_IN, 0, janet_wrap_nil(), janet_wrap_nil()); } static JanetSlot do_get(JanetFopts opts, JanetSlot *args) { if (janet_v_count(args) == 3) { JanetCompiler *c = opts.compiler; JanetSlot t = janetc_gettarget(opts); int target_is_default = janetc_sequal(t, args[2]); JanetSlot dflt_slot = args[2]; if (target_is_default) { dflt_slot = janetc_farslot(c); janetc_copy(c, dflt_slot, t); } janetc_emit_sss(c, JOP_GET, t, args[0], args[1], 1); int32_t label = janetc_emit_si(c, JOP_JUMP_IF_NOT_NIL, t, 0, 0); janetc_copy(c, t, dflt_slot); if (target_is_default) janetc_freeslot(c, dflt_slot); int32_t current = janet_v_count(c->buffer); c->buffer[label] |= (current - label) << 16; return t; } else { return opreduce(opts, args, JOP_GET, 0, janet_wrap_nil(), janet_wrap_nil()); } } static JanetSlot do_next(JanetFopts opts, JanetSlot *args) { return opfunction(opts, args, JOP_NEXT, janet_wrap_nil()); } static JanetSlot do_cmp(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_COMPARE, 0, janet_wrap_nil(), janet_wrap_nil()); } static JanetSlot do_put(JanetFopts opts, JanetSlot *args) { int8_t inline_index = 0; if (can_slot_be_imm(args[1], &inline_index)) { /* Use JOP_PUT_INDEX */ if (opts.flags & JANET_FOPTS_DROP) { janetc_emit_ssi(opts.compiler, JOP_PUT_INDEX, args[0], args[2], inline_index, 0); return janetc_cslot(janet_wrap_nil()); } else { JanetSlot t = janetc_gettarget(opts); janetc_copy(opts.compiler, t, args[0]); janetc_emit_ssi(opts.compiler, JOP_PUT_INDEX, t, args[2], inline_index, 0); return t; } } else { /* Use JOP_PUT */ if (opts.flags & JANET_FOPTS_DROP) { janetc_emit_sss(opts.compiler, JOP_PUT, args[0], args[1], args[2], 0); return janetc_cslot(janet_wrap_nil()); } else { JanetSlot t = janetc_gettarget(opts); janetc_copy(opts.compiler, t, args[0]); janetc_emit_sss(opts.compiler, JOP_PUT, t, args[1], args[2], 0); return t; } } } static JanetSlot do_length(JanetFopts opts, JanetSlot *args) { return genericSS(opts, JOP_LENGTH, args[0]); } static JanetSlot do_yield(JanetFopts opts, JanetSlot *args) { if (janet_v_count(args) == 0) { return genericSSI(opts, JOP_SIGNAL, janetc_cslot(janet_wrap_nil()), 3); } else { return genericSSI(opts, JOP_SIGNAL, args[0], 3); } } static JanetSlot do_resume(JanetFopts opts, JanetSlot *args) { return opfunction(opts, args, JOP_RESUME, janet_wrap_nil()); } static JanetSlot do_cancel(JanetFopts opts, JanetSlot *args) { return opfunction(opts, args, JOP_CANCEL, janet_wrap_nil()); } static JanetSlot do_apply(JanetFopts opts, JanetSlot *args) { /* Push phase */ JanetCompiler *c = opts.compiler; int32_t i; for (i = 1; i < janet_v_count(args) - 3; i += 3) janetc_emit_sss(c, JOP_PUSH_3, args[i], args[i + 1], args[i + 2], 0); if (i == janet_v_count(args) - 3) janetc_emit_ss(c, JOP_PUSH_2, args[i], args[i + 1], 0); else if (i == janet_v_count(args) - 2) janetc_emit_s(c, JOP_PUSH, args[i], 0); /* Push array phase */ janetc_emit_s(c, JOP_PUSH_ARRAY, janet_v_last(args), 0); /* Call phase */ JanetSlot target; if (opts.flags & JANET_FOPTS_TAIL) { janetc_emit_s(c, JOP_TAILCALL, args[0], 0); target = janetc_cslot(janet_wrap_nil()); target.flags |= JANET_SLOT_RETURNED; } else { target = janetc_gettarget(opts); janetc_emit_ss(c, JOP_CALL, target, args[0], 1); } return target; } /* Variadic operators specialization */ static JanetSlot do_add(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_ADD, JOP_ADD_IMMEDIATE, janet_wrap_integer(0), janet_wrap_integer(0)); } static JanetSlot do_sub(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_SUBTRACT, JOP_SUBTRACT_IMMEDIATE, janet_wrap_integer(0), janet_wrap_integer(0)); } static JanetSlot do_mul(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_MULTIPLY, JOP_MULTIPLY_IMMEDIATE, janet_wrap_integer(1), janet_wrap_integer(1)); } static JanetSlot do_div(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_DIVIDE, JOP_DIVIDE_IMMEDIATE, janet_wrap_integer(1), janet_wrap_integer(1)); } static JanetSlot do_divf(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_DIVIDE_FLOOR, 0, janet_wrap_integer(1), janet_wrap_integer(1)); } static JanetSlot do_modulo(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_MODULO, 0, janet_wrap_integer(0), janet_wrap_integer(1)); } static JanetSlot do_remainder(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_REMAINDER, 0, janet_wrap_integer(0), janet_wrap_integer(1)); } static JanetSlot do_band(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_BAND, 0, janet_wrap_integer(-1), janet_wrap_integer(-1)); } static JanetSlot do_bor(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_BOR, 0, janet_wrap_integer(0), janet_wrap_integer(0)); } static JanetSlot do_bxor(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_BXOR, 0, janet_wrap_integer(0), janet_wrap_integer(0)); } static JanetSlot do_lshift(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_SHIFT_LEFT, JOP_SHIFT_LEFT_IMMEDIATE, janet_wrap_integer(1), janet_wrap_integer(1)); } static JanetSlot do_rshift(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_SHIFT_RIGHT, JOP_SHIFT_RIGHT_IMMEDIATE, janet_wrap_integer(1), janet_wrap_integer(1)); } static JanetSlot do_rshiftu(JanetFopts opts, JanetSlot *args) { return opreduce(opts, args, JOP_SHIFT_RIGHT_UNSIGNED, JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE, janet_wrap_integer(1), janet_wrap_integer(1)); } static JanetSlot do_bnot(JanetFopts opts, JanetSlot *args) { return genericSS(opts, JOP_BNOT, args[0]); } /* Specialization for comparators */ static JanetSlot compreduce( JanetFopts opts, JanetSlot *args, int op, int opim, int invert) { JanetCompiler *c = opts.compiler; int32_t i, len; int8_t imm = 0; len = janet_v_count(args); int32_t *labels = NULL; JanetSlot t; if (len < 2) { return invert ? janetc_cslot(janet_wrap_false()) : janetc_cslot(janet_wrap_true()); } t = janetc_gettarget(opts); for (i = 1; i < len; i++) { if (opim && can_slot_be_imm(args[i], &imm)) { janetc_emit_ssi(c, opim, t, args[i - 1], imm, 1); } else { janetc_emit_sss(c, op, t, args[i - 1], args[i], 1); } if (i != (len - 1)) { int32_t label = janetc_emit_si(c, invert ? JOP_JUMP_IF : JOP_JUMP_IF_NOT, t, 0, 1); janet_v_push(labels, label); } } int32_t end = janet_v_count(c->buffer); for (i = 0; i < janet_v_count(labels); i++) { int32_t label = labels[i]; c->buffer[label] |= ((end - label) << 16); } janet_v_free(labels); return t; } static JanetSlot do_gt(JanetFopts opts, JanetSlot *args) { return compreduce(opts, args, JOP_GREATER_THAN, JOP_GREATER_THAN_IMMEDIATE, 0); } static JanetSlot do_lt(JanetFopts opts, JanetSlot *args) { return compreduce(opts, args, JOP_LESS_THAN, JOP_LESS_THAN_IMMEDIATE, 0); } static JanetSlot do_gte(JanetFopts opts, JanetSlot *args) { return compreduce(opts, args, JOP_GREATER_THAN_EQUAL, 0, 0); } static JanetSlot do_lte(JanetFopts opts, JanetSlot *args) { return compreduce(opts, args, JOP_LESS_THAN_EQUAL, 0, 0); } static JanetSlot do_eq(JanetFopts opts, JanetSlot *args) { return compreduce(opts, args, JOP_EQUALS, JOP_EQUALS_IMMEDIATE, 0); } static JanetSlot do_neq(JanetFopts opts, JanetSlot *args) { return compreduce(opts, args, JOP_NOT_EQUALS, JOP_NOT_EQUALS_IMMEDIATE, 1); } /* Arranged by tag */ static const JanetFunOptimizer optimizers[] = { {maxarity1, do_debug}, {fixarity1, do_error}, {minarity2, do_apply}, {maxarity1, do_yield}, {arity1or2, do_resume}, {fixarity2, do_in}, {fixarity3, do_put}, {fixarity1, do_length}, {NULL, do_add}, {NULL, do_sub}, {NULL, do_mul}, {NULL, do_div}, {NULL, do_band}, {NULL, do_bor}, {NULL, do_bxor}, {NULL, do_lshift}, {NULL, do_rshift}, {NULL, do_rshiftu}, {fixarity1, do_bnot}, {NULL, do_gt}, {NULL, do_lt}, {NULL, do_gte}, {NULL, do_lte}, {NULL, do_eq}, {NULL, do_neq}, {fixarity2, do_propagate}, {arity2or3, do_get}, {arity1or2, do_next}, {NULL, do_modulo}, {NULL, do_remainder}, {fixarity2, do_cmp}, {fixarity2, do_cancel}, {NULL, do_divf} }; const JanetFunOptimizer *janetc_funopt(uint32_t flags) { uint32_t tag = flags & JANET_FUNCDEF_FLAG_TAG; if (tag == 0) return NULL; uint32_t index = tag - 1; if (index >= (sizeof(optimizers) / sizeof(optimizers[0]))) return NULL; return optimizers + index; } janet-1.41.2/src/core/compile.c000066400000000000000000001330661514534607600162370ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "compile.h" #include "emit.h" #include "vector.h" #include "util.h" #include "state.h" #endif JanetFopts janetc_fopts_default(JanetCompiler *c) { JanetFopts ret; ret.compiler = c; ret.flags = 0; ret.hint = janetc_cslot(janet_wrap_nil()); return ret; } /* Throw an error with a janet string. */ void janetc_error(JanetCompiler *c, const uint8_t *m) { /* Don't override first error */ if (c->result.status == JANET_COMPILE_ERROR) { return; } c->result.status = JANET_COMPILE_ERROR; c->result.error = m; } /* Throw an error with a message in a cstring */ void janetc_cerror(JanetCompiler *c, const char *m) { janetc_error(c, janet_cstring(m)); } static const char *janet_lint_level_names[] = { "relaxed", "normal", "strict" }; /* Emit compiler linter messages */ void janetc_lintf(JanetCompiler *c, JanetCompileLintLevel level, const char *format, ...) { if (NULL != c->lints) { /* format message */ va_list args; JanetBuffer buffer; int32_t len = 0; while (format[len]) len++; janet_buffer_init(&buffer, len); va_start(args, format); janet_formatbv(&buffer, format, args); va_end(args); const uint8_t *str = janet_string(buffer.data, buffer.count); janet_buffer_deinit(&buffer); /* construct linting payload */ Janet *payload = janet_tuple_begin(4); payload[0] = janet_ckeywordv(janet_lint_level_names[level]); payload[1] = c->current_mapping.line == -1 ? janet_wrap_nil() : janet_wrap_integer(c->current_mapping.line); payload[2] = c->current_mapping.column == -1 ? janet_wrap_nil() : janet_wrap_integer(c->current_mapping.column); payload[3] = janet_wrap_string(str); janet_array_push(c->lints, janet_wrap_tuple(janet_tuple_end(payload))); } } /* Free a slot */ void janetc_freeslot(JanetCompiler *c, JanetSlot s) { if (s.flags & (JANET_SLOT_CONSTANT | JANET_SLOT_REF | JANET_SLOT_NAMED)) return; if (s.envindex >= 0) return; janetc_regalloc_free(&c->scope->ra, s.index); } /* Add a slot to a scope with a symbol associated with it (def or var). */ void janetc_nameslot(JanetCompiler *c, const uint8_t *sym, JanetSlot s) { SymPair sp; int32_t cnt = janet_v_count(c->buffer); sp.sym = sym; sp.sym2 = sym; sp.slot = s; sp.keep = 0; sp.referenced = sym[0] == '_'; /* Fake ref if symbol is _ to avoid lints */ sp.slot.flags |= JANET_SLOT_NAMED; sp.birth_pc = cnt ? cnt - 1 : 0; sp.death_pc = UINT32_MAX; janet_v_push(c->scope->syms, sp); } /* Same as janetc_nameslot, but don't have a lint for unused bindings. */ void janetc_nameslot_no_unused(JanetCompiler *c, const uint8_t *sym, JanetSlot s) { SymPair sp; int32_t cnt = janet_v_count(c->buffer); sp.sym = sym; sp.sym2 = sym; sp.slot = s; sp.keep = 0; sp.referenced = 1; sp.slot.flags |= JANET_SLOT_NAMED; sp.birth_pc = cnt ? cnt - 1 : 0; sp.death_pc = UINT32_MAX; janet_v_push(c->scope->syms, sp); } /* Create a slot with a constant */ JanetSlot janetc_cslot(Janet x) { JanetSlot ret; ret.flags = (1 << janet_type(x)) | JANET_SLOT_CONSTANT; ret.index = -1; ret.constant = x; ret.envindex = -1; return ret; } /* Get a local slot */ JanetSlot janetc_farslot(JanetCompiler *c) { JanetSlot ret; ret.flags = JANET_SLOTTYPE_ANY; ret.index = janetc_allocfar(c); ret.constant = janet_wrap_nil(); ret.envindex = -1; return ret; } /* Enter a new scope */ void janetc_scope(JanetScope *s, JanetCompiler *c, int flags, const char *name) { JanetScope scope; scope.name = name; scope.child = NULL; scope.consts = NULL; scope.syms = NULL; scope.envs = NULL; scope.defs = NULL; scope.bytecode_start = janet_v_count(c->buffer); scope.flags = flags; scope.parent = c->scope; janetc_regalloc_init(&scope.ua); /* Inherit slots */ if ((!(flags & JANET_SCOPE_FUNCTION)) && c->scope) { janetc_regalloc_clone(&scope.ra, &(c->scope->ra)); } else { janetc_regalloc_init(&scope.ra); } /* Link parent and child and update pointer */ if (c->scope) c->scope->child = s; c->scope = s; *s = scope; } /* Leave a scope. */ void janetc_popscope(JanetCompiler *c) { JanetScope *oldscope = c->scope; JanetScope *newscope = oldscope->parent; /* Move free slots to parent scope if not a new function. * We need to know the total number of slots used when compiling the function. */ if (!(oldscope->flags & (JANET_SCOPE_FUNCTION | JANET_SCOPE_UNUSED)) && newscope) { /* Parent scopes inherit child's closure flag. Needed * for while loops. (if a while loop creates a closure, it * is compiled to a tail recursive iife) */ if (oldscope->flags & JANET_SCOPE_CLOSURE) { newscope->flags |= JANET_SCOPE_CLOSURE; } if (newscope->ra.max < oldscope->ra.max) { newscope->ra.max = oldscope->ra.max; } /* Keep upvalue slots and symbols for debugging. */ for (int32_t i = 0; i < janet_v_count(oldscope->syms); i++) { SymPair pair = oldscope->syms[i]; /* Check for unused symbols */ if (pair.referenced == 0 && pair.sym) { janetc_lintf(c, JANET_C_LINT_STRICT, "binding %q is unused", janet_wrap_symbol(pair.sym)); } /* The variable should not be lexically accessible */ pair.sym = NULL; if (pair.death_pc == UINT32_MAX) { pair.death_pc = (uint32_t) janet_v_count(c->buffer); } if (pair.keep) { /* The variable should also not be included in the locals */ pair.sym2 = NULL; janetc_regalloc_touch(&newscope->ra, pair.slot.index); } janet_v_push(newscope->syms, pair); } } /* Free the old scope */ janet_v_free(oldscope->consts); janet_v_free(oldscope->syms); janet_v_free(oldscope->envs); janet_v_free(oldscope->defs); janetc_regalloc_deinit(&oldscope->ra); janetc_regalloc_deinit(&oldscope->ua); /* Update pointer */ if (newscope) newscope->child = NULL; c->scope = newscope; } /* Leave a scope but keep a slot allocated. */ void janetc_popscope_keepslot(JanetCompiler *c, JanetSlot retslot) { JanetScope *scope; janetc_popscope(c); scope = c->scope; if (scope && retslot.envindex < 0 && retslot.index >= 0) { janetc_regalloc_touch(&scope->ra, retslot.index); } } static int lookup_missing( JanetCompiler *c, const uint8_t *sym, JanetFunction *handler, JanetBinding *out) { int32_t minar = handler->def->min_arity; int32_t maxar = handler->def->max_arity; if (minar > 1 || maxar < 1) { janetc_error(c, janet_cstring("missing symbol lookup handler must take 1 argument")); return 0; } Janet args[1] = { janet_wrap_symbol(sym) }; JanetFiber *fiberp = janet_fiber(handler, 64, 1, args); if (NULL == fiberp) { janetc_error(c, janet_cstring("failed to call missing symbol lookup handler")); return 0; } fiberp->env = c->env; int lock = janet_gclock(); Janet tempOut; JanetSignal status = janet_continue(fiberp, janet_wrap_nil(), &tempOut); janet_gcunlock(lock); if (status != JANET_SIGNAL_OK) { janetc_error(c, janet_formatc("(lookup) %V", tempOut)); return 0; } /* Convert return value as entry. */ /* Alternative could use janet_resolve_ext(c->env, sym) to read result from environment. */ *out = janet_binding_from_entry(tempOut); return 1; } /* Allow searching for symbols. Return information about the symbol */ JanetSlot janetc_resolve( JanetCompiler *c, const uint8_t *sym) { JanetSlot ret = janetc_cslot(janet_wrap_nil()); JanetScope *scope = c->scope; SymPair *pair; int foundlocal = 1; int unused = 0; /* Search scopes for symbol, starting from top */ while (scope) { int32_t i, len; if (scope->flags & JANET_SCOPE_UNUSED) unused = 1; len = janet_v_count(scope->syms); /* Search in reverse order */ for (i = len - 1; i >= 0; i--) { pair = scope->syms + i; if (pair->sym == sym) { ret = pair->slot; pair->referenced = 1; goto found; } } if (scope->flags & JANET_SCOPE_FUNCTION) foundlocal = 0; scope = scope->parent; } /* Symbol not found - check for global */ { JanetBinding binding = janet_resolve_ext(c->env, sym); if (binding.type == JANET_BINDING_NONE) { Janet handler = janet_table_get_keyword(c->env, "missing-symbol"); switch (janet_type(handler)) { case JANET_NIL: break; case JANET_FUNCTION: if (!lookup_missing(c, sym, janet_unwrap_function(handler), &binding)) return janetc_cslot(janet_wrap_nil()); break; default: janetc_error(c, janet_formatc("invalid lookup handler %V", handler)); return janetc_cslot(janet_wrap_nil()); } } switch (binding.type) { default: case JANET_BINDING_NONE: janetc_error(c, janet_formatc("unknown symbol %q", janet_wrap_symbol(sym))); return janetc_cslot(janet_wrap_nil()); case JANET_BINDING_DEF: case JANET_BINDING_MACRO: /* Macro should function like defs when not in calling pos */ ret = janetc_cslot(binding.value); break; case JANET_BINDING_DYNAMIC_DEF: case JANET_BINDING_DYNAMIC_MACRO: ret = janetc_cslot(binding.value); ret.flags |= JANET_SLOT_REF | JANET_SLOT_NAMED | JANET_SLOTTYPE_ANY; ret.flags &= ~JANET_SLOT_CONSTANT; break; case JANET_BINDING_VAR: { ret = janetc_cslot(binding.value); ret.flags |= JANET_SLOT_REF | JANET_SLOT_NAMED | JANET_SLOT_MUTABLE | JANET_SLOTTYPE_ANY; ret.flags &= ~JANET_SLOT_CONSTANT; break; } } JanetCompileLintLevel depLevel = JANET_C_LINT_RELAXED; switch (binding.deprecation) { case JANET_BINDING_DEP_NONE: break; case JANET_BINDING_DEP_RELAXED: depLevel = JANET_C_LINT_RELAXED; break; case JANET_BINDING_DEP_NORMAL: depLevel = JANET_C_LINT_NORMAL; break; case JANET_BINDING_DEP_STRICT: depLevel = JANET_C_LINT_STRICT; break; } if (binding.deprecation != JANET_BINDING_DEP_NONE) { janetc_lintf(c, depLevel, "%q is deprecated", janet_wrap_symbol(sym)); } return ret; } /* Symbol was found */ found: /* Constants can be returned immediately (they are stateless) */ if (ret.flags & (JANET_SLOT_CONSTANT | JANET_SLOT_REF)) return ret; /* Unused references and locals shouldn't add captured envs. */ if (unused || foundlocal) { ret.envindex = -1; return ret; } /* non-local scope needs to expose its environment */ JanetScope *original_scope = scope; pair->keep = 1; pair->referenced = 1; while (scope && !(scope->flags & JANET_SCOPE_FUNCTION)) scope = scope->parent; janet_assert(scope, "invalid scopes"); scope->flags |= JANET_SCOPE_ENV; /* In the function scope, allocate the slot as an upvalue */ janetc_regalloc_touch(&scope->ua, ret.index); /* Iterate through child scopes and make sure environment is propagated */ scope = scope->child; /* Propagate env up to current scope */ int32_t envindex = -1; while (scope) { if (scope->flags & JANET_SCOPE_FUNCTION) { int32_t j, len; int scopefound = 0; /* Check if scope already has env. If so, break */ len = janet_v_count(scope->envs); for (j = 0; j < len; j++) { if (scope->envs[j].envindex == envindex) { scopefound = 1; envindex = j; break; } } /* Add the environment if it is not already referenced */ if (!scopefound) { len = janet_v_count(scope->envs); JanetEnvRef ref; ref.envindex = envindex; ref.scope = original_scope; janet_v_push(scope->envs, ref); envindex = len; } } scope = scope->child; } ret.envindex = envindex; return ret; } /* Generate the return instruction for a slot. */ JanetSlot janetc_return(JanetCompiler *c, JanetSlot s) { if (!(s.flags & JANET_SLOT_RETURNED)) { if (s.flags & JANET_SLOT_CONSTANT && janet_checktype(s.constant, JANET_NIL)) janetc_emit(c, JOP_RETURN_NIL); else janetc_emit_s(c, JOP_RETURN, s, 0); s.flags |= JANET_SLOT_RETURNED; } return s; } /* Get a target slot for emitting an instruction. */ JanetSlot janetc_gettarget(JanetFopts opts) { JanetSlot slot; if ((opts.flags & JANET_FOPTS_HINT) && (opts.hint.envindex < 0) && (opts.hint.index >= 0 && opts.hint.index <= 0xFF)) { slot = opts.hint; } else { slot.envindex = -1; slot.constant = janet_wrap_nil(); slot.flags = 0; slot.index = janetc_allocfar(opts.compiler); } return slot; } /* Get a bunch of slots for function arguments */ JanetSlot *janetc_toslots(JanetCompiler *c, const Janet *vals, int32_t len) { int32_t i; JanetSlot *ret = NULL; JanetFopts subopts = janetc_fopts_default(c); subopts.flags |= JANET_FOPTS_ACCEPT_SPLICE; for (i = 0; i < len; i++) { janet_v_push(ret, janetc_value(subopts, vals[i])); } return ret; } /* Get a bunch of slots for function arguments */ JanetSlot *janetc_toslotskv(JanetCompiler *c, Janet ds) { JanetSlot *ret = NULL; JanetFopts subopts = janetc_fopts_default(c); subopts.flags |= JANET_FOPTS_ACCEPT_SPLICE; const JanetKV *kvs = NULL; int32_t cap = 0, len = 0; janet_dictionary_view(ds, &kvs, &len, &cap); /* Sort keys for stability of order? */ int32_t *index_buf; int32_t index_buf_stack[32]; int32_t *index_buf_heap = NULL; if (len < 32) { index_buf = index_buf_stack; } else { index_buf_heap = janet_smalloc(sizeof(int32_t) * len); index_buf = index_buf_heap; } if (len) janet_sorted_keys(kvs, cap, index_buf); for (int32_t i = 0; i < len; i++) { janet_v_push(ret, janetc_value(subopts, kvs[index_buf[i]].key)); janet_v_push(ret, janetc_value(subopts, kvs[index_buf[i]].value)); } if (index_buf_heap) janet_sfree(index_buf_heap); return ret; } /* Push slots loaded via janetc_toslots. Return the minimum number of slots pushed, * or -1 - min_arity if there is a splice. (if there is no splice, min_arity is also * the maximum possible arity). */ int32_t janetc_pushslots(JanetCompiler *c, JanetSlot *slots) { int32_t i; int32_t count = janet_v_count(slots); int32_t min_arity = 0; int has_splice = 0; for (i = 0; i < count;) { if (slots[i].flags & JANET_SLOT_SPLICED) { janetc_emit_s(c, JOP_PUSH_ARRAY, slots[i], 0); i++; has_splice = 1; } else if (i + 1 == count) { janetc_emit_s(c, JOP_PUSH, slots[i], 0); i++; min_arity++; } else if (slots[i + 1].flags & JANET_SLOT_SPLICED) { janetc_emit_s(c, JOP_PUSH, slots[i], 0); janetc_emit_s(c, JOP_PUSH_ARRAY, slots[i + 1], 0); i += 2; min_arity++; has_splice = 1; } else if (i + 2 == count) { janetc_emit_ss(c, JOP_PUSH_2, slots[i], slots[i + 1], 0); i += 2; min_arity += 2; } else if (slots[i + 2].flags & JANET_SLOT_SPLICED) { janetc_emit_ss(c, JOP_PUSH_2, slots[i], slots[i + 1], 0); janetc_emit_s(c, JOP_PUSH_ARRAY, slots[i + 2], 0); i += 3; min_arity += 2; has_splice = 1; } else { janetc_emit_sss(c, JOP_PUSH_3, slots[i], slots[i + 1], slots[i + 2], 0); i += 3; min_arity += 3; } } return has_splice ? (-1 - min_arity) : min_arity; } /* Check if a list of slots has any spliced slots */ static int has_spliced(JanetSlot *slots) { int32_t i; for (i = 0; i < janet_v_count(slots); i++) { if (slots[i].flags & JANET_SLOT_SPLICED) return 1; } return 0; } /* Free slots loaded via janetc_toslots */ void janetc_freeslots(JanetCompiler *c, JanetSlot *slots) { int32_t i; for (i = 0; i < janet_v_count(slots); i++) { janetc_freeslot(c, slots[i]); } janet_v_free(slots); } /* Compile some code that will be thrown away. Used to ensure * that dead code is well formed without including it in the final * bytecode. */ void janetc_throwaway(JanetFopts opts, Janet x) { JanetCompiler *c = opts.compiler; JanetScope unusedScope; int32_t bufstart = janet_v_count(c->buffer); int32_t mapbufstart = janet_v_count(c->mapbuffer); janetc_scope(&unusedScope, c, JANET_SCOPE_UNUSED, "unused"); janetc_value(opts, x); janetc_lintf(c, JANET_C_LINT_STRICT, "dead code, consider removing %.4q", x); janetc_popscope(c); if (c->buffer) { janet_v__cnt(c->buffer) = bufstart; if (c->mapbuffer) janet_v__cnt(c->mapbuffer) = mapbufstart; } } /* Compile a call or tailcall instruction */ static JanetSlot janetc_call(JanetFopts opts, JanetSlot *slots, JanetSlot fun, const Janet *form) { JanetSlot retslot; JanetCompiler *c = opts.compiler; int specialized = 0; if (fun.flags & JANET_SLOT_CONSTANT && !has_spliced(slots)) { if (janet_checktype(fun.constant, JANET_FUNCTION)) { JanetFunction *f = janet_unwrap_function(fun.constant); const JanetFunOptimizer *o = janetc_funopt(f->def->flags); if (o && (!o->can_optimize || o->can_optimize(opts, slots))) { specialized = 1; retslot = o->optimize(opts, slots); } } /* TODO janet function inlining (no c functions)*/ } if (!specialized) { int32_t min_arity = janetc_pushslots(c, slots); /* Check for provably incorrect function calls */ if (fun.flags & JANET_SLOT_CONSTANT) { /* Check for bad arity type if fun is a constant */ switch (janet_type(fun.constant)) { case JANET_FUNCTION: { JanetFunction *f = janet_unwrap_function(fun.constant); int32_t min = f->def->min_arity; int32_t max = f->def->max_arity; int structarg = f->def->flags & JANET_FUNCDEF_FLAG_STRUCTARG; int namedarg = f->def->flags & JANET_FUNCDEF_FLAG_NAMEDARGS; if (min_arity < 0) { /* Call has splices */ min_arity = -1 - min_arity; if (min_arity > max && max >= 0) { const uint8_t *es = janet_formatc( "%v expects at most %d argument%s, got at least %d", fun.constant, max, max == 1 ? "" : "s", min_arity); janetc_error(c, es); } } else { /* Call has no splices */ if (min_arity > max && max >= 0) { const uint8_t *es = janet_formatc( "%v expects at most %d argument%s, got %d", fun.constant, max, max == 1 ? "" : "s", min_arity); janetc_error(c, es); } if (min_arity < min) { const uint8_t *es = janet_formatc( "%v expects at least %d argument%s, got %d", fun.constant, min, min == 1 ? "" : "s", min_arity); janetc_error(c, es); } if (structarg && (min_arity > f->def->arity) && ((min_arity - f->def->arity) & 1)) { /* If we have an odd number of variadic arguments to a `&keys` function, that is almost certainly wrong. */ if (namedarg) { janetc_lintf(c, JANET_C_LINT_NORMAL, "odd number of named arguments to `&named` function %v", fun.constant); } else { janetc_lintf(c, JANET_C_LINT_NORMAL, "odd number of named arguments to `&keys` function %v", fun.constant); } } if (namedarg && f->def->named_args_count > 0) { /* For each argument passed in, check if it is one of the used named arguments * by checking the list defined in the function def. If not, raise a normal compiler * lint. We can also do a strict lint for _missing_ named arguments, although in many * cases those are assumed to have some kind of default, or we have dynamic keys. */ int32_t first_arg_key_index = f->def->arity + 1; for (int32_t i = first_arg_key_index; i < janet_tuple_length(form); i += 2) { Janet argkey = form[i]; /* Assumption: The first N constants of a function are its named argument keys. This * may change if the compiler changes, but is true for all Janet generated functions. */ int found = 0; if (janet_checktype(argkey, JANET_KEYWORD)) { for (int32_t j = 0; j < f->def->named_args_count && j < f->def->constants_length; j++) { if (janet_equals(argkey, f->def->constants[j])) { found = 1; break; } } } else if (janet_checktype(argkey, JANET_TUPLE)) { /* Possible lint : too dynamic, be dumber * (defn f [&named x] [x]) * (f (if (coin-flip) :x :w) 10) * A tuple could be a function call the evaluates to a valid key */ found = 1; } if (!found) { janetc_lintf(c, JANET_C_LINT_NORMAL, "unused named argument %v to function %v", argkey, fun.constant); } } } } } break; case JANET_CFUNCTION: case JANET_ABSTRACT: case JANET_NIL: break; case JANET_KEYWORD: if (min_arity == 0) { const uint8_t *es = janet_formatc("%v expects at least 1 argument, got 0", fun.constant); janetc_error(c, es); } break; default: if (min_arity > 1 || min_arity == 0) { const uint8_t *es = janet_formatc("%v expects 1 argument, got %d", fun.constant, min_arity); janetc_error(c, es); } if (min_arity < -2) { const uint8_t *es = janet_formatc("%v expects 1 argument, got at least %d", fun.constant, -1 - min_arity); janetc_error(c, es); } break; } } if ((opts.flags & JANET_FOPTS_TAIL) && /* Prevent top level tail calls for better errors */ !(c->scope->flags & JANET_SCOPE_TOP)) { janetc_emit_s(c, JOP_TAILCALL, fun, 0); retslot = janetc_cslot(janet_wrap_nil()); retslot.flags = JANET_SLOT_RETURNED; } else { retslot = janetc_gettarget(opts); janetc_emit_ss(c, JOP_CALL, retslot, fun, 1); } } janetc_freeslots(c, slots); return retslot; } static JanetSlot janetc_maker(JanetFopts opts, JanetSlot *slots, int op) { JanetCompiler *c = opts.compiler; JanetSlot retslot; /* Check if this structure is composed entirely of constants */ int can_inline = 1; for (int32_t i = 0; i < janet_v_count(slots); i++) { if (!(slots[i].flags & JANET_SLOT_CONSTANT) || (slots[i].flags & JANET_SLOT_SPLICED)) { can_inline = 0; break; } } if (can_inline && (op == JOP_MAKE_STRUCT)) { JanetKV *st = janet_struct_begin(janet_v_count(slots) / 2); for (int32_t i = 0; i < janet_v_count(slots); i += 2) { Janet k = slots[i].constant; Janet v = slots[i + 1].constant; janet_struct_put(st, k, v); } retslot = janetc_cslot(janet_wrap_struct(janet_struct_end(st))); janetc_freeslots(c, slots); } else if (can_inline && (op == JOP_MAKE_TUPLE)) { Janet *tup = janet_tuple_begin(janet_v_count(slots)); for (int32_t i = 0; i < janet_v_count(slots); i++) { tup[i] = slots[i].constant; } retslot = janetc_cslot(janet_wrap_tuple(janet_tuple_end(tup))); janetc_freeslots(c, slots); } else { janetc_pushslots(c, slots); janetc_freeslots(c, slots); retslot = janetc_gettarget(opts); janetc_emit_s(c, op, retslot, 1); } return retslot; } static JanetSlot janetc_array(JanetFopts opts, Janet x) { JanetCompiler *c = opts.compiler; JanetArray *a = janet_unwrap_array(x); return janetc_maker(opts, janetc_toslots(c, a->data, a->count), JOP_MAKE_ARRAY); } static JanetSlot janetc_tuple(JanetFopts opts, Janet x) { JanetCompiler *c = opts.compiler; const Janet *t = janet_unwrap_tuple(x); return janetc_maker(opts, janetc_toslots(c, t, janet_tuple_length(t)), JOP_MAKE_TUPLE); } static JanetSlot janetc_tablector(JanetFopts opts, Janet x, int op) { JanetCompiler *c = opts.compiler; return janetc_maker(opts, janetc_toslotskv(c, x), op); } static JanetSlot janetc_bufferctor(JanetFopts opts, Janet x) { JanetCompiler *c = opts.compiler; JanetBuffer *b = janet_unwrap_buffer(x); Janet onearg = janet_stringv(b->data, b->count); return janetc_maker(opts, janetc_toslots(c, &onearg, 1), JOP_MAKE_BUFFER); } /* Expand a macro one time. Also get the special form compiler if we * find that instead. */ static int macroexpand1( JanetCompiler *c, Janet x, Janet *out, const JanetSpecial **spec) { if (!janet_checktype(x, JANET_TUPLE)) return 0; const Janet *form = janet_unwrap_tuple(x); if (janet_tuple_length(form) == 0) return 0; /* Source map - only set when we get a tuple */ if (janet_tuple_sm_line(form) >= 0) { c->current_mapping.line = janet_tuple_sm_line(form); c->current_mapping.column = janet_tuple_sm_column(form); } /* Bracketed tuples are not specials or macros! */ if (janet_tuple_flag(form) & JANET_TUPLE_FLAG_BRACKETCTOR) return 0; if (!janet_checktype(form[0], JANET_SYMBOL)) return 0; const uint8_t *name = janet_unwrap_symbol(form[0]); const JanetSpecial *s = janetc_special(name); if (s) { *spec = s; return 0; } Janet macroval; JanetBindingType btype = janet_resolve(c->env, name, ¯oval); if (!(btype == JANET_BINDING_MACRO || btype == JANET_BINDING_DYNAMIC_MACRO) || !janet_checktype(macroval, JANET_FUNCTION)) return 0; /* Evaluate macro */ JanetFunction *macro = janet_unwrap_function(macroval); int32_t arity = janet_tuple_length(form) - 1; JanetFiber *fiberp = janet_fiber(macro, 64, arity, form + 1); if (NULL == fiberp) { int32_t minar = macro->def->min_arity; int32_t maxar = macro->def->max_arity; const uint8_t *es = NULL; if (minar >= 0 && arity < minar) es = janet_formatc("macro arity mismatch, expected at least %d, got %d", minar, arity); if (maxar >= 0 && arity > maxar) es = janet_formatc("macro arity mismatch, expected at most %d, got %d", maxar, arity); c->result.macrofiber = NULL; janetc_error(c, es); return 0; } /* Set env */ fiberp->env = c->env; int lock = janet_gclock(); Janet mf_kw = janet_ckeywordv("macro-form"); janet_table_put(c->env, mf_kw, x); Janet ml_kw = janet_ckeywordv("macro-lints"); if (c->lints) { janet_table_put(c->env, ml_kw, janet_wrap_array(c->lints)); } Janet tempOut; JanetSignal status = janet_continue(fiberp, janet_wrap_nil(), &tempOut); janet_table_put(c->env, mf_kw, janet_wrap_nil()); janet_table_put(c->env, ml_kw, janet_wrap_nil()); janet_gcunlock(lock); if (status != JANET_SIGNAL_OK) { const uint8_t *es = janet_formatc("(macro) %V", tempOut); c->result.macrofiber = fiberp; janetc_error(c, es); return 0; } else { *out = tempOut; } return 1; } /* Compile a single value */ JanetSlot janetc_value(JanetFopts opts, Janet x) { JanetSlot ret; JanetCompiler *c = opts.compiler; JanetSourceMapping last_mapping = c->current_mapping; c->recursion_guard--; /* Guard against previous errors and unbounded recursion */ if (c->result.status == JANET_COMPILE_ERROR) return janetc_cslot(janet_wrap_nil()); if (c->recursion_guard <= 0) { janetc_cerror(c, "recursed too deeply"); return janetc_cslot(janet_wrap_nil()); } /* Macro expand. Also gets possible special form and * refines source mapping cursor if possible. */ const JanetSpecial *spec = NULL; int macroi = JANET_MAX_MACRO_EXPAND; while (macroi && c->result.status != JANET_COMPILE_ERROR && macroexpand1(c, x, &x, &spec)) macroi--; if (macroi == 0) { janetc_cerror(c, "recursed too deeply in macro expansion"); return janetc_cslot(janet_wrap_nil()); } /* Special forms */ if (spec) { const Janet *tup = janet_unwrap_tuple(x); ret = spec->compile(opts, janet_tuple_length(tup) - 1, tup + 1); } else { switch (janet_type(x)) { case JANET_TUPLE: { JanetFopts subopts = janetc_fopts_default(c); const Janet *tup = janet_unwrap_tuple(x); /* Empty tuple is tuple literal */ if (janet_tuple_length(tup) == 0) { ret = janetc_cslot(janet_wrap_tuple(janet_tuple_n(NULL, 0))); } else if (janet_tuple_flag(tup) & JANET_TUPLE_FLAG_BRACKETCTOR) { /* [] tuples are not function call */ ret = janetc_tuple(opts, x); } else { /* Function calls */ JanetSlot head = janetc_value(subopts, tup[0]); subopts.flags = JANET_FUNCTION | JANET_CFUNCTION; ret = janetc_call(opts, janetc_toslots(c, tup + 1, janet_tuple_length(tup) - 1), head, tup); janetc_freeslot(c, head); } ret.flags &= ~JANET_SLOT_SPLICED; } break; /* Data Constructors */ case JANET_SYMBOL: ret = janetc_resolve(c, janet_unwrap_symbol(x)); break; case JANET_ARRAY: ret = janetc_array(opts, x); break; case JANET_STRUCT: ret = janetc_tablector(opts, x, JOP_MAKE_STRUCT); break; case JANET_TABLE: ret = janetc_tablector(opts, x, JOP_MAKE_TABLE); break; case JANET_BUFFER: ret = janetc_bufferctor(opts, x); break; default: ret = janetc_cslot(x); break; } } if (c->result.status == JANET_COMPILE_ERROR) return janetc_cslot(janet_wrap_nil()); if (opts.flags & JANET_FOPTS_TAIL) ret = janetc_return(c, ret); if (opts.flags & JANET_FOPTS_HINT) { janetc_copy(c, opts.hint, ret); ret = opts.hint; } c->current_mapping = last_mapping; c->recursion_guard++; return ret; } /* Add function flags to janet functions */ void janet_def_addflags(JanetFuncDef *def) { int32_t set_flags = 0; int32_t unset_flags = 0; /* pos checks */ if (def->name) set_flags |= JANET_FUNCDEF_FLAG_HASNAME; if (def->source) set_flags |= JANET_FUNCDEF_FLAG_HASSOURCE; if (def->defs) set_flags |= JANET_FUNCDEF_FLAG_HASDEFS; if (def->environments) set_flags |= JANET_FUNCDEF_FLAG_HASENVS; if (def->sourcemap) set_flags |= JANET_FUNCDEF_FLAG_HASSOURCEMAP; if (def->closure_bitset) set_flags |= JANET_FUNCDEF_FLAG_HASCLOBITSET; if (def->named_args_count) set_flags |= JANET_FUNCDEF_FLAG_NAMEDARGS; /* negative checks */ if (!def->name) unset_flags |= JANET_FUNCDEF_FLAG_HASNAME; if (!def->source) unset_flags |= JANET_FUNCDEF_FLAG_HASSOURCE; if (!def->defs) unset_flags |= JANET_FUNCDEF_FLAG_HASDEFS; if (!def->environments) unset_flags |= JANET_FUNCDEF_FLAG_HASENVS; if (!def->sourcemap) unset_flags |= JANET_FUNCDEF_FLAG_HASSOURCEMAP; if (!def->closure_bitset) unset_flags |= JANET_FUNCDEF_FLAG_HASCLOBITSET; if (!def->named_args_count) unset_flags |= JANET_FUNCDEF_FLAG_NAMEDARGS; /* Update flags */ def->flags |= set_flags; def->flags &= ~unset_flags; } /* Compile a funcdef */ /* Once the various other settings of the FuncDef have been tweaked, * call janet_def_addflags to set the proper flags for the funcdef */ JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c) { JanetScope *scope = c->scope; JanetFuncDef *def = janet_funcdef_alloc(); def->slotcount = scope->ra.max + 1; janet_assert(scope->flags & JANET_SCOPE_FUNCTION, "expected function scope"); /* Copy envs */ def->environments_length = janet_v_count(scope->envs); def->environments = janet_malloc(sizeof(int32_t) * def->environments_length); for (int32_t i = 0; i < def->environments_length; i++) { def->environments[i] = scope->envs[i].envindex; } def->constants_length = janet_v_count(scope->consts); def->constants = janet_v_flatten(scope->consts); def->defs_length = janet_v_count(scope->defs); def->defs = janet_v_flatten(scope->defs); /* Copy bytecode (only last chunk) */ def->bytecode_length = janet_v_count(c->buffer) - scope->bytecode_start; if (def->bytecode_length) { size_t s = sizeof(int32_t) * (size_t) def->bytecode_length; def->bytecode = janet_malloc(s); if (NULL == def->bytecode) { JANET_OUT_OF_MEMORY; } safe_memcpy(def->bytecode, c->buffer + scope->bytecode_start, s); janet_v__cnt(c->buffer) = scope->bytecode_start; if (NULL != c->mapbuffer && c->source) { size_t s = sizeof(JanetSourceMapping) * (size_t) def->bytecode_length; def->sourcemap = janet_malloc(s); if (NULL == def->sourcemap) { JANET_OUT_OF_MEMORY; } safe_memcpy(def->sourcemap, c->mapbuffer + scope->bytecode_start, s); janet_v__cnt(c->mapbuffer) = scope->bytecode_start; } } /* Get source from parser */ def->source = c->source; def->arity = 0; def->min_arity = 0; def->flags = 0; if (scope->flags & JANET_SCOPE_ENV) { def->flags |= JANET_FUNCDEF_FLAG_NEEDSENV; } /* Copy upvalue bitset */ if (scope->ua.count) { /* Number of u32s we need to create a bitmask for all slots */ int32_t slotchunks = (def->slotcount + 31) >> 5; /* numchunks is min of slotchunks and scope->ua.count */ int32_t numchunks = slotchunks > scope->ua.count ? scope->ua.count : slotchunks; uint32_t *chunks = janet_calloc(slotchunks, sizeof(uint32_t)); if (NULL == chunks) { JANET_OUT_OF_MEMORY; } memcpy(chunks, scope->ua.chunks, sizeof(uint32_t) * numchunks); /* fprintf(stderr, "slot chunks: %d, scope->ua.count: %d, numchunks: %d\n", slotchunks, scope->ua.count, numchunks); */ /* Register allocator preallocates some registers [240-255, high 16 bits of chunk index 7], we can ignore those. */ if (scope->ua.count > 7 && slotchunks > 7) chunks[7] &= 0xFFFFU; def->closure_bitset = chunks; } /* Capture symbol to local mapping */ JanetSymbolMap *locals = NULL; /* Symbol -> upvalue mapping */ JanetScope *top = c->scope; while (top->parent) top = top->parent; for (JanetScope *s = top; s != NULL; s = s->child) { for (int32_t j = 0; j < janet_v_count(scope->envs); j++) { JanetEnvRef ref = scope->envs[j]; JanetScope *upscope = ref.scope; if (upscope != s) continue; for (int32_t i = 0; i < janet_v_count(upscope->syms); i++) { SymPair pair = upscope->syms[i]; if (pair.sym2) { JanetSymbolMap jsm; jsm.birth_pc = UINT32_MAX; jsm.death_pc = j; jsm.slot_index = pair.slot.index; jsm.symbol = pair.sym2; janet_v_push(locals, jsm); } } } } /* Symbol -> slot mapping */ for (int32_t i = 0; i < janet_v_count(scope->syms); i++) { SymPair pair = scope->syms[i]; if (pair.sym2) { JanetSymbolMap jsm; /* Check for unused symbols */ if (pair.referenced == 0 && pair.sym) { janetc_lintf(c, JANET_C_LINT_STRICT, "binding %q is unused", janet_wrap_symbol(pair.sym)); } if (pair.death_pc == UINT32_MAX) { jsm.death_pc = def->bytecode_length; } else { jsm.death_pc = pair.death_pc - scope->bytecode_start; } /* Handle birth_pc == 0 correctly */ if ((uint32_t) scope->bytecode_start > pair.birth_pc) { jsm.birth_pc = 0; } else { jsm.birth_pc = pair.birth_pc - scope->bytecode_start; } janet_assert(jsm.birth_pc <= jsm.death_pc, "birth pc after death pc"); janet_assert(jsm.birth_pc < (uint32_t) def->bytecode_length, "bad birth pc"); janet_assert(jsm.death_pc <= (uint32_t) def->bytecode_length, "bad death pc"); jsm.slot_index = pair.slot.index; jsm.symbol = pair.sym2; janet_v_push(locals, jsm); } } def->symbolmap_length = janet_v_count(locals); def->symbolmap = janet_v_flatten(locals); if (def->symbolmap_length) def->flags |= JANET_FUNCDEF_FLAG_HASSYMBOLMAP; /* Pop the scope */ janetc_popscope(c); /* Do basic optimization */ janet_bytecode_movopt(def); janet_bytecode_remove_noops(def); return def; } /* Initialize a compiler */ static void janetc_init(JanetCompiler *c, JanetTable *env, const uint8_t *where, JanetArray *lints) { c->scope = NULL; c->buffer = NULL; c->mapbuffer = NULL; c->recursion_guard = JANET_RECURSION_GUARD; c->env = env; c->source = where; c->current_mapping.line = -1; c->current_mapping.column = -1; c->lints = lints; /* Init result */ c->result.error = NULL; c->result.status = JANET_COMPILE_OK; c->result.funcdef = NULL; c->result.macrofiber = NULL; c->result.error_mapping.line = -1; c->result.error_mapping.column = -1; } /* Deinitialize a compiler struct */ static void janetc_deinit(JanetCompiler *c) { janet_v_free(c->buffer); janet_v_free(c->mapbuffer); c->env = NULL; } /* Compile a form. */ JanetCompileResult janet_compile_lint(Janet source, JanetTable *env, const uint8_t *where, JanetArray *lints) { JanetCompiler c; JanetScope rootscope; JanetFopts fopts; janetc_init(&c, env, where, lints); /* Push a function scope */ janetc_scope(&rootscope, &c, JANET_SCOPE_FUNCTION | JANET_SCOPE_TOP, "root"); /* Set initial form options */ fopts.compiler = &c; fopts.flags = JANET_FOPTS_TAIL | JANET_SLOTTYPE_ANY; fopts.hint = janetc_cslot(janet_wrap_nil()); /* Compile the value */ janetc_value(fopts, source); if (c.result.status == JANET_COMPILE_OK) { JanetFuncDef *def = janetc_pop_funcdef(&c); def->name = janet_cstring("thunk"); janet_def_addflags(def); c.result.funcdef = def; } else { c.result.error_mapping = c.current_mapping; janetc_popscope(&c); } janetc_deinit(&c); return c.result; } JanetCompileResult janet_compile(Janet source, JanetTable *env, const uint8_t *where) { return janet_compile_lint(source, env, where, NULL); } /* C Function for compiling */ JANET_CORE_FN(cfun_compile, "(compile ast &opt env source lints)", "Compiles an Abstract Syntax Tree (ast) into a function. " "Pair the compile function with parsing functionality to implement " "eval. Returns a new function and does not modify ast. Returns an error " "struct with keys :line, :column, and :error if compilation fails. " "If a `lints` array is given, linting messages will be appended to the array. " "Each message will be a tuple of the form `(level line col message)`.") { janet_sandbox_assert(JANET_SANDBOX_COMPILE); janet_arity(argc, 1, 4); JanetTable *env = (argc > 1 && !janet_checktype(argv[1], JANET_NIL)) ? janet_gettable(argv, 1) : janet_vm.fiber->env; if (NULL == env) { env = janet_table(0); janet_vm.fiber->env = env; } const uint8_t *source = NULL; if (argc >= 3) { Janet x = argv[2]; if (janet_checktype(x, JANET_STRING)) { source = janet_unwrap_string(x); } else if (janet_checktype(x, JANET_KEYWORD)) { source = janet_unwrap_keyword(x); } else if (!janet_checktype(x, JANET_NIL)) { janet_panic_type(x, 2, JANET_TFLAG_STRING | JANET_TFLAG_KEYWORD); } } JanetArray *lints = (argc >= 4 && !janet_checktype(argv[3], JANET_NIL)) ? janet_getarray(argv, 3) : NULL; JanetCompileResult res = janet_compile_lint(argv[0], env, source, lints); if (res.status == JANET_COMPILE_OK) { return janet_wrap_function(janet_thunk(res.funcdef)); } else { JanetTable *t = janet_table(4); janet_table_put(t, janet_ckeywordv("error"), janet_wrap_string(res.error)); if (res.error_mapping.line > 0) { janet_table_put(t, janet_ckeywordv("line"), janet_wrap_integer(res.error_mapping.line)); } if (res.error_mapping.column > 0) { janet_table_put(t, janet_ckeywordv("column"), janet_wrap_integer(res.error_mapping.column)); } if (res.macrofiber) { janet_table_put(t, janet_ckeywordv("fiber"), janet_wrap_fiber(res.macrofiber)); } return janet_wrap_table(t); } } void janet_lib_compile(JanetTable *env) { JanetRegExt cfuns[] = { JANET_CORE_REG("compile", cfun_compile), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, cfuns); } janet-1.41.2/src/core/compile.h000066400000000000000000000200161514534607600162320ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_COMPILE_H #define JANET_COMPILE_H #ifndef JANET_AMALG #include "features.h" #include #include "regalloc.h" #endif /* Levels for compiler warnings */ typedef enum { JANET_C_LINT_RELAXED, JANET_C_LINT_NORMAL, JANET_C_LINT_STRICT } JanetCompileLintLevel; /* Tags for some functions for the prepared inliner */ #define JANET_FUN_DEBUG 1 #define JANET_FUN_ERROR 2 #define JANET_FUN_APPLY 3 #define JANET_FUN_YIELD 4 #define JANET_FUN_RESUME 5 #define JANET_FUN_IN 6 #define JANET_FUN_PUT 7 #define JANET_FUN_LENGTH 8 #define JANET_FUN_ADD 9 #define JANET_FUN_SUBTRACT 10 #define JANET_FUN_MULTIPLY 11 #define JANET_FUN_DIVIDE 12 #define JANET_FUN_BAND 13 #define JANET_FUN_BOR 14 #define JANET_FUN_BXOR 15 #define JANET_FUN_LSHIFT 16 #define JANET_FUN_RSHIFT 17 #define JANET_FUN_RSHIFTU 18 #define JANET_FUN_BNOT 19 #define JANET_FUN_GT 20 #define JANET_FUN_LT 21 #define JANET_FUN_GTE 22 #define JANET_FUN_LTE 23 #define JANET_FUN_EQ 24 #define JANET_FUN_NEQ 25 #define JANET_FUN_PROP 26 #define JANET_FUN_GET 27 #define JANET_FUN_NEXT 28 #define JANET_FUN_MODULO 29 #define JANET_FUN_REMAINDER 30 #define JANET_FUN_CMP 31 #define JANET_FUN_CANCEL 32 #define JANET_FUN_DIVIDE_FLOOR 33 /* Compiler typedefs */ typedef struct JanetCompiler JanetCompiler; typedef struct FormOptions FormOptions; typedef struct SlotTracker SlotTracker; typedef struct JanetScope JanetScope; typedef struct JanetSlot JanetSlot; typedef struct JanetFopts JanetFopts; typedef struct JanetFunOptimizer JanetFunOptimizer; typedef struct JanetSpecial JanetSpecial; #define JANET_SLOT_CONSTANT 0x10000 #define JANET_SLOT_NAMED 0x20000 #define JANET_SLOT_MUTABLE 0x40000 #define JANET_SLOT_REF 0x80000 #define JANET_SLOT_RETURNED 0x100000 #define JANET_SLOT_DEP_NOTE 0x200000 #define JANET_SLOT_DEP_WARN 0x400000 #define JANET_SLOT_DEP_ERROR 0x800000 #define JANET_SLOT_SPLICED 0x1000000 #define JANET_SLOTTYPE_ANY 0xFFFF /* A stack slot */ struct JanetSlot { Janet constant; /* If the slot has a constant value */ int32_t index; int32_t envindex; /* 0 is local, positive number is an upvalue */ uint32_t flags; }; #define JANET_SCOPE_FUNCTION 1 #define JANET_SCOPE_ENV 2 #define JANET_SCOPE_TOP 4 #define JANET_SCOPE_UNUSED 8 #define JANET_SCOPE_CLOSURE 16 #define JANET_SCOPE_WHILE 32 /* A symbol and slot pair */ typedef struct SymPair { JanetSlot slot; const uint8_t *sym; const uint8_t *sym2; int keep; int referenced; /* Has this value been used */ uint32_t birth_pc; uint32_t death_pc; } SymPair; typedef struct JanetEnvRef { int32_t envindex; JanetScope *scope; } JanetEnvRef; /* A lexical scope during compilation */ struct JanetScope { /* For debugging the compiler */ const char *name; /* Scopes are doubly linked list */ JanetScope *parent; JanetScope *child; /* Constants for this funcdef */ Janet *consts; /* Map of symbols to slots. Use a simple linear scan for symbols. */ SymPair *syms; /* FuncDefs */ JanetFuncDef **defs; /* Register allocator */ JanetcRegisterAllocator ra; /* Upvalue allocator */ JanetcRegisterAllocator ua; /* Referenced closure environments. The values at each index correspond * to which index to get the environment from in the parent. The environment * that corresponds to the direct parent's stack will always have value 0. */ JanetEnvRef *envs; int32_t bytecode_start; int flags; }; /* Compilation state */ struct JanetCompiler { /* Pointer to current scope */ JanetScope *scope; uint32_t *buffer; JanetSourceMapping *mapbuffer; /* Hold the environment */ JanetTable *env; /* Name of source to attach to generated functions */ const uint8_t *source; /* The result of compilation */ JanetCompileResult result; /* Keep track of where we are in the source */ JanetSourceMapping current_mapping; /* Prevent unbounded recursion */ int recursion_guard; /* Collect linting results */ JanetArray *lints; }; #define JANET_FOPTS_TAIL 0x10000 #define JANET_FOPTS_HINT 0x20000 #define JANET_FOPTS_DROP 0x40000 #define JANET_FOPTS_ACCEPT_SPLICE 0x80000 /* Options for compiling a single form */ struct JanetFopts { JanetCompiler *compiler; JanetSlot hint; uint32_t flags; /* bit set of accepted primitive types */ }; /* Get the default form options */ JanetFopts janetc_fopts_default(JanetCompiler *c); /* For optimizing builtin normal functions. */ struct JanetFunOptimizer { int (*can_optimize)(JanetFopts opts, JanetSlot *args); JanetSlot(*optimize)(JanetFopts opts, JanetSlot *args); }; /* A grouping of a named special and the corresponding compiler fragment */ struct JanetSpecial { const char *name; JanetSlot(*compile)(JanetFopts opts, int32_t argn, const Janet *argv); }; /****************************************************/ /* Get an optimizer if it exists, otherwise NULL */ const JanetFunOptimizer *janetc_funopt(uint32_t flags); /* Get a special. Return NULL if none exists */ const JanetSpecial *janetc_special(const uint8_t *name); void janetc_freeslot(JanetCompiler *c, JanetSlot s); void janetc_nameslot(JanetCompiler *c, const uint8_t *sym, JanetSlot s); void janetc_nameslot_no_unused(JanetCompiler *c, const uint8_t *sym, JanetSlot s); JanetSlot janetc_farslot(JanetCompiler *c); /* Throw away some code after checking that it is well formed. */ void janetc_throwaway(JanetFopts opts, Janet x); /* Get a target slot for emitting an instruction. Will always return * a local slot. */ JanetSlot janetc_gettarget(JanetFopts opts); /* Get a bunch of slots for function arguments */ JanetSlot *janetc_toslots(JanetCompiler *c, const Janet *vals, int32_t len); /* Get a bunch of slots for function arguments */ JanetSlot *janetc_toslotskv(JanetCompiler *c, Janet ds); /* Push slots loaded via janetc_toslots. */ int32_t janetc_pushslots(JanetCompiler *c, JanetSlot *slots); /* Free slots loaded via janetc_toslots */ void janetc_freeslots(JanetCompiler *c, JanetSlot *slots); /* Generate the return instruction for a slot. */ JanetSlot janetc_return(JanetCompiler *c, JanetSlot s); /* Store an error */ void janetc_error(JanetCompiler *c, const uint8_t *m); void janetc_cerror(JanetCompiler *c, const char *m); /* Linting */ void janetc_lintf(JanetCompiler *C, JanetCompileLintLevel level, const char *format, ...); /* Dispatch to correct form compiler */ JanetSlot janetc_value(JanetFopts opts, Janet x); /* Push and pop from the scope stack */ void janetc_scope(JanetScope *s, JanetCompiler *c, int flags, const char *name); void janetc_popscope(JanetCompiler *c); void janetc_popscope_keepslot(JanetCompiler *c, JanetSlot retslot); JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c); /* Create a destroy slot */ JanetSlot janetc_cslot(Janet x); /* Search for a symbol */ JanetSlot janetc_resolve(JanetCompiler *c, const uint8_t *sym); /* Bytecode optimization */ void janet_bytecode_movopt(JanetFuncDef *def); void janet_bytecode_remove_noops(JanetFuncDef *def); #endif janet-1.41.2/src/core/corelib.c000066400000000000000000001573501514534607600162300ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include #include "compile.h" #include "state.h" #include "util.h" #include "fiber.h" #endif /* Generated bytes */ #ifndef JANET_BOOTSTRAP extern const unsigned char *janet_core_image; extern size_t janet_core_image_size; #endif /* Docstrings should only exist during bootstrap */ #ifdef JANET_BOOTSTRAP #define JDOC(x) (x) #else #define JDOC(x) NULL #endif JanetModule janet_native(const char *name, const uint8_t **error) { janet_sandbox_assert(JANET_SANDBOX_DYNAMIC_MODULES); char *processed_name = get_processed_name(name); Clib lib = load_clib(processed_name); JanetModule init; JanetModconf getter; if (name != processed_name) janet_free(processed_name); if (!lib) { *error = janet_cstring(error_clib()); return NULL; } init = (JanetModule) symbol_clib(lib, "_janet_init"); if (!init) { *error = janet_cstring("could not find the _janet_init symbol"); return NULL; } getter = (JanetModconf) symbol_clib(lib, "_janet_mod_config"); if (!getter) { *error = janet_cstring("could not find the _janet_mod_config symbol"); return NULL; } JanetBuildConfig modconf = getter(); JanetBuildConfig host = janet_config_current(); if (host.major != modconf.major || host.minor != modconf.minor || host.bits != modconf.bits) { char errbuf[128]; snprintf(errbuf, sizeof(errbuf), "config mismatch - host %d.%.d.%d(%.4x) vs. module %d.%d.%d(%.4x)", host.major, host.minor, host.patch, host.bits, modconf.major, modconf.minor, modconf.patch, modconf.bits); *error = janet_cstring(errbuf); return NULL; } return init; } static const char *janet_dyncstring(const char *name, const char *dflt) { Janet x = janet_dyn(name); if (janet_checktype(x, JANET_NIL)) return dflt; if (!janet_checktype(x, JANET_STRING)) { janet_panicf("expected string, got %v", x); } const uint8_t *jstr = janet_unwrap_string(x); const char *cstr = (const char *)jstr; if (strlen(cstr) != (size_t) janet_string_length(jstr)) { janet_panicf("string %v contains embedded 0s", x); } return cstr; } static int is_path_sep(char c) { #ifdef JANET_WINDOWS if (c == '\\') return 1; #endif return c == '/'; } /* Used for module system. */ JANET_CORE_FN(janet_core_expand_path, "(module/expand-path path template)", "Expands a path template as found in `module/paths` for `module/find`. " "This takes in a path (the argument to require) and a template string, " "to expand the path to a path that can be used for importing files. " "The replacements are as follows:\n\n" "* :all: -- the value of path verbatim.\n\n" "* :@all: -- Same as :all:, but if `path` starts with the @ character, " "the first path segment is replaced with a dynamic binding " "`(dyn )`.\n\n" "* :cur: -- the directory portion, if any, of (dyn :current-file)\n\n" "* :dir: -- the directory portion, if any, of the path argument\n\n" "* :name: -- the name component of path, with extension if given\n\n" "* :native: -- the extension used to load natives, .so or .dll\n\n" "* :sys: -- the system path, or (dyn :syspath)") { janet_fixarity(argc, 2); const char *input = janet_getcstring(argv, 0); const char *template = janet_getcstring(argv, 1); const char *curfile = janet_dyncstring("current-file", ""); const char *syspath = janet_dyncstring("syspath", ""); JanetBuffer *out = janet_buffer(0); size_t tlen = strlen(template); /* Calculate name */ const char *name = input + strlen(input); while (name > input) { if (is_path_sep(*(name - 1))) break; name--; } /* Calculate dirpath from current file */ const char *curname = curfile + strlen(curfile); while (curname > curfile) { if (is_path_sep(*curname)) break; curname--; } const char *curdir; int32_t curlen; if (curname == curfile) { /* Current file has one or zero path segments, so * we are in the . directory. */ curdir = "."; curlen = 1; } else { /* Current file has 2 or more segments, so we * can cut off the last segment. */ curdir = curfile; curlen = (int32_t)(curname - curfile); } for (size_t i = 0; i < tlen; i++) { if (template[i] == ':') { if (strncmp(template + i, ":all:", 5) == 0) { janet_buffer_push_cstring(out, input); i += 4; } else if (strncmp(template + i, ":@all:", 6) == 0) { if (input[0] == '@') { const char *p = input; while (*p && !is_path_sep(*p)) p++; size_t len = p - input - 1; char *str = janet_smalloc(len + 1); memcpy(str, input + 1, len); str[len] = '\0'; janet_formatb(out, "%V", janet_dyn(str)); janet_sfree(str); janet_buffer_push_cstring(out, p); } else { janet_buffer_push_cstring(out, input); } i += 5; } else if (strncmp(template + i, ":cur:", 5) == 0) { janet_buffer_push_bytes(out, (const uint8_t *)curdir, curlen); i += 4; } else if (strncmp(template + i, ":dir:", 5) == 0) { janet_buffer_push_bytes(out, (const uint8_t *)input, (int32_t)(name - input)); i += 4; } else if (strncmp(template + i, ":sys:", 5) == 0) { janet_buffer_push_cstring(out, syspath); i += 4; } else if (strncmp(template + i, ":name:", 6) == 0) { janet_buffer_push_cstring(out, name); i += 5; } else if (strncmp(template + i, ":native:", 8) == 0) { #ifdef JANET_WINDOWS janet_buffer_push_cstring(out, ".dll"); #else janet_buffer_push_cstring(out, ".so"); #endif i += 7; } else { janet_buffer_push_u8(out, (uint8_t) template[i]); } } else { janet_buffer_push_u8(out, (uint8_t) template[i]); } } /* Normalize */ uint8_t *scan = out->data; uint8_t *print = scan; uint8_t *scanend = scan + out->count; int normal_section_count = 0; int dot_count = 0; while (scan < scanend) { if (*scan == '.') { if (dot_count >= 0) { dot_count++; } else { *print++ = '.'; } } else if (is_path_sep(*scan)) { if (dot_count == 1) { ; } else if (dot_count == 2) { if (normal_section_count > 0) { /* unprint last separator */ print--; /* unprint last section */ while (print > out->data && !is_path_sep(*(print - 1))) print--; normal_section_count--; } else { *print++ = '.'; *print++ = '.'; *print++ = '/'; } } else if (scan == out->data || dot_count != 0) { while (dot_count > 0) { --dot_count; *print++ = '.'; } if (scan > out->data) { normal_section_count++; } *print++ = '/'; } dot_count = 0; } else { while (dot_count > 0) { --dot_count; *print++ = '.'; } dot_count = -1; *print++ = *scan; } scan++; } out->count = (int32_t)(print - out->data); return janet_wrap_buffer(out); } JANET_CORE_FN(janet_core_dyn, "(dyn key &opt default)", "Get a dynamic binding. Returns the default value (or nil) if no binding found.") { janet_arity(argc, 1, 2); Janet value; if (janet_vm.fiber->env) { value = janet_table_get(janet_vm.fiber->env, argv[0]); } else { value = janet_wrap_nil(); } if (argc == 2 && janet_checktype(value, JANET_NIL)) { return argv[1]; } return value; } JANET_CORE_FN(janet_core_setdyn, "(setdyn key value)", "Set a dynamic binding. Returns value.") { janet_fixarity(argc, 2); if (!janet_vm.fiber->env) { janet_vm.fiber->env = janet_table(2); } janet_table_put(janet_vm.fiber->env, argv[0], argv[1]); return argv[1]; } JANET_CORE_FN(janet_core_native, "(native path &opt env)", "Load a native module from the given path. The path " "must be an absolute or relative path on the file system, and is " "usually a .so file on Unix systems, and a .dll file on Windows. " "Returns an environment table that contains functions and other values " "from the native module.") { JanetModule init; janet_arity(argc, 1, 2); Janet argv0 = argv[0]; const uint8_t *path = janet_getstring(argv, 0); const uint8_t *error = NULL; JanetTable *env; if (argc == 2) { env = janet_gettable(argv, 1); } else { env = janet_table(0); } init = janet_native((const char *)path, &error); if (!init) { janet_panicf("could not load native %S: %S", path, error); } /* GC root incase garbage collection called inside module entry */ janet_fiber_push(janet_vm.fiber, janet_wrap_table(env)); init(env); janet_table_put(env, janet_ckeywordv("native"), argv0); return janet_wrap_table(env); } JANET_CORE_FN(janet_core_describe, "(describe x)", "Returns a string that is a human-readable description of `x`. " "For recursive data structures, the string returned contains a " "pointer value from which the identity of `x` " "can be determined.") { JanetBuffer *b = janet_buffer(0); for (int32_t i = 0; i < argc; ++i) janet_description_b(b, argv[i]); return janet_stringv(b->data, b->count); } JANET_CORE_FN(janet_core_string, "(string & xs)", "Creates a string by concatenating the elements of `xs` together. If an " "element is not a byte sequence, it is converted to bytes via `describe`. " "Returns the new string.") { JanetBuffer *b = janet_buffer(0); for (int32_t i = 0; i < argc; ++i) janet_to_string_b(b, argv[i]); return janet_stringv(b->data, b->count); } JANET_CORE_FN(janet_core_symbol, "(symbol & xs)", "Creates a symbol by concatenating the elements of `xs` together. If an " "element is not a byte sequence, it is converted to bytes via `describe`. " "Returns the new symbol.") { JanetBuffer *b = janet_buffer(0); for (int32_t i = 0; i < argc; ++i) janet_to_string_b(b, argv[i]); return janet_symbolv(b->data, b->count); } JANET_CORE_FN(janet_core_keyword, "(keyword & xs)", "Creates a keyword by concatenating the elements of `xs` together. If an " "element is not a byte sequence, it is converted to bytes via `describe`. " "Returns the new keyword.") { JanetBuffer *b = janet_buffer(0); for (int32_t i = 0; i < argc; ++i) janet_to_string_b(b, argv[i]); return janet_keywordv(b->data, b->count); } JANET_CORE_FN(janet_core_buffer, "(buffer & xs)", "Creates a buffer by concatenating the elements of `xs` together. If an " "element is not a byte sequence, it is converted to bytes via `describe`. " "Returns the new buffer.") { JanetBuffer *b = janet_buffer(0); for (int32_t i = 0; i < argc; ++i) janet_to_string_b(b, argv[i]); return janet_wrap_buffer(b); } JANET_CORE_FN(janet_core_is_abstract, "(abstract? x)", "Check if x is an abstract type.") { janet_fixarity(argc, 1); return janet_wrap_boolean(janet_checktype(argv[0], JANET_ABSTRACT)); } JANET_CORE_FN(janet_core_scannumber, "(scan-number str &opt base)", "Parse a number from a byte sequence and return that number, either an integer " "or a real. The number " "must be in the same format as numbers in janet source code. Will return nil " "on an invalid number. Optionally provide a base - if a base is provided, no " "radix specifier is expected at the beginning of the number.") { double number; janet_arity(argc, 1, 2); JanetByteView view = janet_getbytes(argv, 0); int32_t base = janet_optinteger(argv, argc, 1, 0); int valid = base == 0 || (base >= 2 && base <= 36); if (!valid) { janet_panicf("expected base between 2 and 36, got %d", base); } if (janet_scan_number_base(view.bytes, view.len, base, &number)) return janet_wrap_nil(); return janet_wrap_number(number); } JANET_CORE_FN(janet_core_tuple, "(tuple & items)", "Creates a new tuple that contains items. Returns the new tuple.") { return janet_wrap_tuple(janet_tuple_n(argv, argc)); } JANET_CORE_FN(janet_core_array, "(array & items)", "Create a new array that contains items. Returns the new array.") { JanetArray *array = janet_array(argc); array->count = argc; safe_memcpy(array->data, argv, argc * sizeof(Janet)); return janet_wrap_array(array); } JANET_CORE_FN(janet_core_slice, "(slice x &opt start end)", "Extract a sub-range of an indexed data structure or byte sequence.") { JanetRange range; JanetByteView bview; JanetView iview; if (janet_bytes_view(argv[0], &bview.bytes, &bview.len)) { range = janet_getslice(argc, argv); return janet_stringv(bview.bytes + range.start, range.end - range.start); } else if (janet_indexed_view(argv[0], &iview.items, &iview.len)) { range = janet_getslice(argc, argv); return janet_wrap_tuple(janet_tuple_n(iview.items + range.start, range.end - range.start)); } else { janet_panic_type(argv[0], 0, JANET_TFLAG_BYTES | JANET_TFLAG_INDEXED); } } JANET_CORE_FN(janet_core_range, "(range & args)", "Create an array of values [start, end) with a given step. " "With one argument, returns a range [0, end). With two arguments, returns " "a range [start, end). With three, returns a range with optional step size.") { janet_arity(argc, 1, 3); double start = 0, stop = 0, step = 1, count = 0; if (argc == 3) { start = janet_getnumber(argv, 0); stop = janet_getnumber(argv, 1); step = janet_getnumber(argv, 2); count = (step > 0) ? (stop - start) / step : ((step < 0) ? (stop - start) / step : 0); } else if (argc == 2) { start = janet_getnumber(argv, 0); stop = janet_getnumber(argv, 1); count = stop - start; } else { stop = janet_getnumber(argv, 0); count = stop; } count = (count > 0) ? count : 0; int32_t int_count; janet_assert(count >= 0, "bad range code"); if (count > (double) INT32_MAX) { janet_panicf("range is too large, %f elements", count); } else { int_count = (int32_t) ceil(count); } if (step > 0.0) { janet_assert(start + int_count * step >= stop, "bad range code"); } else { janet_assert(start + int_count * step <= stop, "bad range code"); } JanetArray *array = janet_array(int_count); for (int32_t i = 0; i < int_count; i++) { array->data[i] = janet_wrap_number((double) start + (double) i * step); } array->count = int_count; return janet_wrap_array(array); } JANET_CORE_FN(janet_core_table, "(table & kvs)", "Creates a new table from a variadic number of keys and values. " "kvs is a sequence k1, v1, k2, v2, k3, v3, ... If kvs has " "an odd number of elements, an error will be thrown. Returns the " "new table.") { int32_t i; if (argc & 1) janet_panic("expected even number of arguments"); JanetTable *table = janet_table(argc >> 1); for (i = 0; i < argc; i += 2) { janet_table_put(table, argv[i], argv[i + 1]); } return janet_wrap_table(table); } JANET_CORE_FN(janet_core_getproto, "(getproto x)", "Get the prototype of a table or struct. Will return nil if `x` has no prototype.") { janet_fixarity(argc, 1); if (janet_checktype(argv[0], JANET_TABLE)) { JanetTable *t = janet_unwrap_table(argv[0]); return t->proto ? janet_wrap_table(t->proto) : janet_wrap_nil(); } if (janet_checktype(argv[0], JANET_STRUCT)) { JanetStruct st = janet_unwrap_struct(argv[0]); return janet_struct_proto(st) ? janet_wrap_struct(janet_struct_proto(st)) : janet_wrap_nil(); } janet_panicf("expected struct or table, got %v", argv[0]); } JANET_CORE_FN(janet_core_struct, "(struct & kvs)", "Create a new struct from a sequence of key value pairs. " "kvs is a sequence k1, v1, k2, v2, k3, v3, ... If kvs has " "an odd number of elements, an error will be thrown. Returns the " "new struct.") { int32_t i; if (argc & 1) { janet_panic("expected even number of arguments"); } JanetKV *st = janet_struct_begin(argc >> 1); for (i = 0; i < argc; i += 2) { janet_struct_put(st, argv[i], argv[i + 1]); } return janet_wrap_struct(janet_struct_end(st)); } JANET_CORE_FN(janet_core_gensym, "(gensym)", "Returns a new symbol that is unique across the runtime. This means it " "will not collide with any already created symbols during compilation, so " "it can be used in macros to generate automatic bindings.") { (void) argv; janet_fixarity(argc, 0); return janet_wrap_symbol(janet_symbol_gen()); } JANET_CORE_FN(janet_core_gccollect, "(gccollect)", "Run garbage collection. You should probably not call this manually.") { (void) argv; (void) argc; janet_collect(); return janet_wrap_nil(); } JANET_CORE_FN(janet_core_gcsetinterval, "(gcsetinterval interval)", "Set an integer number of bytes to allocate before running garbage collection. " "Low values for interval will be slower but use less memory. " "High values will be faster but use more memory.") { janet_fixarity(argc, 1); size_t s = janet_getsize(argv, 0); /* limit interval to 48 bits */ #ifdef JANET_64 if (s >> 48) { janet_panic("interval too large"); } #endif janet_vm.gc_interval = s; return janet_wrap_nil(); } JANET_CORE_FN(janet_core_gcinterval, "(gcinterval)", "Returns the integer number of bytes to allocate before running an iteration " "of garbage collection.") { (void) argv; janet_fixarity(argc, 0); return janet_wrap_number((double) janet_vm.gc_interval); } JANET_CORE_FN(janet_core_type, "(type x)", "Returns the type of `x` as a keyword. `x` is one of:\n\n" "* :nil\n\n" "* :boolean\n\n" "* :number\n\n" "* :array\n\n" "* :tuple\n\n" "* :table\n\n" "* :struct\n\n" "* :string\n\n" "* :buffer\n\n" "* :symbol\n\n" "* :keyword\n\n" "* :function\n\n" "* :cfunction\n\n" "* :fiber\n\n" "or another keyword for an abstract type.") { janet_fixarity(argc, 1); JanetType t = janet_type(argv[0]); if (t == JANET_ABSTRACT) { return janet_ckeywordv(janet_abstract_type(janet_unwrap_abstract(argv[0]))->name); } else { return janet_ckeywordv(janet_type_names[t]); } } JANET_CORE_FN(janet_core_hash, "(hash value)", "Gets a hash for any value. The hash is an integer can be used " "as a cheap hash function for all values. If two values are strictly equal, " "then they will have the same hash value.") { janet_fixarity(argc, 1); return janet_wrap_number(janet_hash(argv[0])); } JANET_CORE_FN(janet_core_getline, "(getline &opt prompt buf env)", "Reads a line of input into a buffer, including the newline character, using a prompt. " "An optional environment table can be provided for auto-complete. " "Returns the modified buffer. " "Use this function to implement a simple interface for a terminal program.") { FILE *in = janet_dynfile("in", stdin); FILE *out = janet_dynfile("out", stdout); janet_arity(argc, 0, 3); JanetBuffer *buf = (argc >= 2) ? janet_getbuffer(argv, 1) : janet_buffer(10); if (argc >= 1) { const char *prompt = (const char *) janet_getstring(argv, 0); fprintf(out, "%s", prompt); fflush(out); } { buf->count = 0; int c; for (;;) { c = fgetc(in); if (feof(in) || c < 0) { break; } janet_buffer_push_u8(buf, (uint8_t) c); if (c == '\n') break; } } return janet_wrap_buffer(buf); } JANET_CORE_FN(janet_core_trace, "(trace func)", "Enable tracing on a function. Returns the function.") { janet_fixarity(argc, 1); JanetFunction *func = janet_getfunction(argv, 0); func->gc.flags |= JANET_FUNCFLAG_TRACE; return argv[0]; } JANET_CORE_FN(janet_core_untrace, "(untrace func)", "Disables tracing on a function. Returns the function.") { janet_fixarity(argc, 1); JanetFunction *func = janet_getfunction(argv, 0); func->gc.flags &= ~JANET_FUNCFLAG_TRACE; return argv[0]; } JANET_CORE_FN(janet_core_check_int, "(int? x)", "Check if x can be exactly represented as a 32 bit signed two's complement integer.") { janet_fixarity(argc, 1); return janet_wrap_boolean(janet_checkint(argv[0])); } JANET_CORE_FN(janet_core_check_nat, "(nat? x)", "Check if x can be exactly represented as a non-negative 32 bit signed two's complement integer.") { janet_fixarity(argc, 1); if (!janet_checkint(argv[0])) return janet_wrap_false(); return janet_wrap_boolean(janet_unwrap_integer(argv[0]) >= 0); } JANET_CORE_FN(janet_core_is_bytes, "(bytes? x)", "Check if x is a string, symbol, keyword, or buffer.") { janet_fixarity(argc, 1); return janet_wrap_boolean(janet_checktypes(argv[0], JANET_TFLAG_BYTES)); } JANET_CORE_FN(janet_core_is_indexed, "(indexed? x)", "Check if x is an array or tuple.") { janet_fixarity(argc, 1); return janet_wrap_boolean(janet_checktypes(argv[0], JANET_TFLAG_INDEXED)); } JANET_CORE_FN(janet_core_is_dictionary, "(dictionary? x)", "Check if x is a table or struct.") { janet_fixarity(argc, 1); return janet_wrap_boolean(janet_checktypes(argv[0], JANET_TFLAG_DICTIONARY)); } JANET_CORE_FN(janet_core_is_lengthable, "(lengthable? x)", "Check if x is a bytes, indexed, or dictionary.") { janet_fixarity(argc, 1); return janet_wrap_boolean(janet_checktypes(argv[0], JANET_TFLAG_LENGTHABLE)); } JANET_CORE_FN(janet_core_signal, "(signal what x)", "Raise a signal with payload x. `what` can be an integer\n" "from 0 through 7 indicating user(0-7), or one of:\n\n" "* :ok\n" "* :error\n" "* :debug\n" "* :yield\n" "* :user(0-7)\n" "* :interrupt\n" "* :await") { janet_arity(argc, 1, 2); Janet payload = argc == 2 ? argv[1] : janet_wrap_nil(); if (janet_checkint(argv[0])) { int32_t s = janet_unwrap_integer(argv[0]); if (s < 0 || s > 9) { janet_panicf("expected user signal between 0 and 9, got %d", s); } janet_signalv(JANET_SIGNAL_USER0 + s, payload); } else { JanetKeyword kw = janet_getkeyword(argv, 0); for (unsigned i = 0; i < sizeof(janet_signal_names) / sizeof(char *); i++) { if (!janet_cstrcmp(kw, janet_signal_names[i])) { janet_signalv((JanetSignal) i, payload); } } } janet_panicf("unknown signal %v", argv[0]); } JANET_CORE_FN(janet_core_memcmp, "(memcmp a b &opt len offset-a offset-b)", "Compare memory. Takes two byte sequences `a` and `b`, and " "return 0 if they have identical contents, a negative integer if a is less than b, " "and a positive integer if a is greater than b. Optionally take a length and offsets " "to compare slices of the bytes sequences.") { janet_arity(argc, 2, 5); JanetByteView a = janet_getbytes(argv, 0); JanetByteView b = janet_getbytes(argv, 1); int32_t len = janet_optnat(argv, argc, 2, a.len < b.len ? a.len : b.len); int32_t offset_a = janet_optnat(argv, argc, 3, 0); int32_t offset_b = janet_optnat(argv, argc, 4, 0); if (offset_a + len > a.len) janet_panicf("invalid offset-a: %d", offset_a); if (offset_b + len > b.len) janet_panicf("invalid offset-b: %d", offset_b); return janet_wrap_integer(memcmp(a.bytes + offset_a, b.bytes + offset_b, (size_t) len)); } typedef struct SandboxOption { const char *name; uint32_t flag; } SandboxOption; static const SandboxOption sandbox_options[] = { {"all", JANET_SANDBOX_ALL}, {"asm", JANET_SANDBOX_ASM}, {"chroot", JANET_SANDBOX_CHROOT}, {"compile", JANET_SANDBOX_COMPILE}, {"env", JANET_SANDBOX_ENV}, {"ffi", JANET_SANDBOX_FFI}, {"ffi-define", JANET_SANDBOX_FFI_DEFINE}, {"ffi-jit", JANET_SANDBOX_FFI_JIT}, {"ffi-use", JANET_SANDBOX_FFI_USE}, {"fs", JANET_SANDBOX_FS}, {"fs-read", JANET_SANDBOX_FS_READ}, {"fs-temp", JANET_SANDBOX_FS_TEMP}, {"fs-write", JANET_SANDBOX_FS_WRITE}, {"hrtime", JANET_SANDBOX_HRTIME}, {"modules", JANET_SANDBOX_DYNAMIC_MODULES}, {"net", JANET_SANDBOX_NET}, {"net-connect", JANET_SANDBOX_NET_CONNECT}, {"net-listen", JANET_SANDBOX_NET_LISTEN}, {"sandbox", JANET_SANDBOX_SANDBOX}, {"signal", JANET_SANDBOX_SIGNAL}, {"subprocess", JANET_SANDBOX_SUBPROCESS}, {"threads", JANET_SANDBOX_THREADS}, {"unmarshal", JANET_SANDBOX_UNMARSHAL}, {NULL, 0} }; JANET_CORE_FN(janet_core_sandbox, "(sandbox & forbidden-capabilities)", "Disable feature sets to prevent the interpreter from using certain system resources. " "Once a feature is disabled, there is no way to re-enable it. Capabilities can be:\n\n" "* :all - disallow all (except IO to stdout, stderr, and stdin)\n" "* :asm - disallow calling `asm` and `disasm` functions.\n" "* :chroot - disallow calling `os/posix-chroot`\n" "* :compile - disallow calling `compile`. This will disable a lot of functionality, such as `eval`.\n" "* :env - disallow reading and write env variables\n" "* :ffi - disallow FFI (recommended if disabling anything else)\n" "* :ffi-define - disallow loading new FFI modules and binding new functions\n" "* :ffi-jit - disallow calling `ffi/jitfn`\n" "* :ffi-use - disallow using any previously bound FFI functions and memory-unsafe functions.\n" "* :fs - disallow access to the file system\n" "* :fs-read - disallow read access to the file system\n" "* :fs-temp - disallow creating temporary files\n" "* :fs-write - disallow write access to the file system\n" "* :hrtime - disallow high-resolution timers\n" "* :modules - disallow load dynamic modules (natives)\n" "* :net - disallow network access\n" "* :net-connect - disallow making outbound network connections\n" "* :net-listen - disallow accepting inbound network connections\n" "* :sandbox - disallow calling this function\n" "* :signal - disallow adding or removing signal handlers\n" "* :subprocess - disallow running subprocesses\n" "* :threads - disallow spawning threads with `ev/thread`. Certain helper threads may still be spawned.\n" "* :unmarshal - disallow calling the unmarshal function.\n") { uint32_t flags = 0; for (int32_t i = 0; i < argc; i++) { JanetKeyword kw = janet_getkeyword(argv, i); const SandboxOption *opt = sandbox_options; while (opt->name != NULL) { if (janet_cstrcmp(kw, opt->name) == 0) { flags |= opt->flag; break; } opt++; } if (opt->name == NULL) janet_panicf("unknown capability %v", argv[i]); } janet_sandbox(flags); return janet_wrap_nil(); } #ifdef JANET_BOOTSTRAP /* Utility for inline assembly */ static void janet_quick_asm( JanetTable *env, int32_t flags, const char *name, int32_t arity, int32_t min_arity, int32_t max_arity, int32_t slots, const uint32_t *bytecode, size_t bytecode_size, const char *doc) { JanetFuncDef *def = janet_funcdef_alloc(); def->arity = arity; def->min_arity = min_arity; def->max_arity = max_arity; def->flags = flags; def->slotcount = slots; def->bytecode = janet_malloc(bytecode_size); def->bytecode_length = (int32_t)(bytecode_size / sizeof(uint32_t)); def->name = janet_cstring(name); if (!def->bytecode) { JANET_OUT_OF_MEMORY; } memcpy(def->bytecode, bytecode, bytecode_size); janet_def_addflags(def); janet_def(env, name, janet_wrap_function(janet_thunk(def)), doc); } /* Macros for easier inline assembly */ #define SSS(op, a, b, c) ((op) | ((a) << 8) | ((b) << 16) | ((c) << 24)) #define SS(op, a, b) ((op) | ((a) << 8) | ((b) << 16)) #define SSI(op, a, b, I) ((op) | ((a) << 8) | ((b) << 16) | ((uint32_t)(I) << 24)) #define S(op, a) ((op) | ((a) << 8)) #define SI(op, a, I) ((op) | ((a) << 8) | ((uint32_t)(I) << 16)) /* Templatize a varop */ static void templatize_varop( JanetTable *env, int32_t flags, const char *name, int32_t nullary, int32_t unary, uint32_t op, const char *doc) { /* Variadic operator assembly. Must be templatized for each different opcode. */ /* Reg 0: Argument tuple (args) */ /* Reg 1: Argument count (argn) */ /* Reg 2: Jump flag (jump?) */ /* Reg 3: Accumulator (accum) */ /* Reg 4: Next operand (operand) */ /* Reg 5: Loop iterator (i) */ uint32_t varop_asm[] = { SS(JOP_LENGTH, 1, 0), /* Put number of arguments in register 1 -> argn = count(args) */ /* Check nullary */ SSS(JOP_EQUALS_IMMEDIATE, 2, 1, 0), /* Check if numargs equal to 0 */ SI(JOP_JUMP_IF_NOT, 2, 3), /* If not 0, jump to next check */ /* Nullary */ SI(JOP_LOAD_INTEGER, 3, nullary), /* accum = nullary value */ S(JOP_RETURN, 3), /* return accum */ /* Check unary */ SSI(JOP_EQUALS_IMMEDIATE, 2, 1, 1), /* Check if numargs equal to 1 */ SI(JOP_JUMP_IF_NOT, 2, 5), /* If not 1, jump to next check */ /* Unary */ SI(JOP_LOAD_INTEGER, 3, unary), /* accum = unary value */ SSI(JOP_GET_INDEX, 4, 0, 0), /* operand = args[0] */ SSS(op, 3, 3, 4), /* accum = accum op operand */ S(JOP_RETURN, 3), /* return accum */ /* Mutli (2 or more) arity */ /* Prime loop */ SSI(JOP_GET_INDEX, 3, 0, 0), /* accum = args[0] */ SI(JOP_LOAD_INTEGER, 5, 1), /* i = 1 */ /* Main loop */ SSS(JOP_IN, 4, 0, 5), /* operand = args[i] */ SSS(op, 3, 3, 4), /* accum = accum op operand */ SSI(JOP_ADD_IMMEDIATE, 5, 5, 1), /* i++ */ SSI(JOP_EQUALS, 2, 5, 1), /* jump? = (i == argn) */ SI(JOP_JUMP_IF_NOT, 2, -4), /* if not jump? go back 4 */ /* Done, do last and return accumulator */ S(JOP_RETURN, 3) /* return accum */ }; janet_quick_asm( env, flags | JANET_FUNCDEF_FLAG_VARARG, name, 0, 0, INT32_MAX, 6, varop_asm, sizeof(varop_asm), doc); } /* Templatize variadic comparators */ static void templatize_comparator( JanetTable *env, int32_t flags, const char *name, int invert, uint32_t op, const char *doc) { /* Reg 0: Argument tuple (args) */ /* Reg 1: Argument count (argn) */ /* Reg 2: Jump flag (jump?) */ /* Reg 3: Last value (last) */ /* Reg 4: Next operand (next) */ /* Reg 5: Loop iterator (i) */ uint32_t comparator_asm[] = { SS(JOP_LENGTH, 1, 0), /* Put number of arguments in register 1 -> argn = count(args) */ SSS(JOP_LESS_THAN_IMMEDIATE, 2, 1, 2), /* Check if numargs less than 2 */ SI(JOP_JUMP_IF, 2, 10), /* If numargs < 2, jump to done */ /* Prime loop */ SSI(JOP_GET_INDEX, 3, 0, 0), /* last = args[0] */ SI(JOP_LOAD_INTEGER, 5, 1), /* i = 1 */ /* Main loop */ SSS(JOP_IN, 4, 0, 5), /* next = args[i] */ SSS(op, 2, 3, 4), /* jump? = last compare next */ SI(JOP_JUMP_IF_NOT, 2, 7), /* if not jump? goto fail (return false) */ SSI(JOP_ADD_IMMEDIATE, 5, 5, 1), /* i++ */ SS(JOP_MOVE_NEAR, 3, 4), /* last = next */ SSI(JOP_EQUALS, 2, 5, 1), /* jump? = (i == argn) */ SI(JOP_JUMP_IF_NOT, 2, -6), /* if not jump? go back 6 */ /* Done, return true */ S(invert ? JOP_LOAD_FALSE : JOP_LOAD_TRUE, 3), S(JOP_RETURN, 3), /* Failed, return false */ S(invert ? JOP_LOAD_TRUE : JOP_LOAD_FALSE, 3), S(JOP_RETURN, 3) }; janet_quick_asm( env, flags | JANET_FUNCDEF_FLAG_VARARG, name, 0, 0, INT32_MAX, 6, comparator_asm, sizeof(comparator_asm), doc); } /* Make the apply function */ static void make_apply(JanetTable *env) { /* Reg 0: Function (fun) */ /* Reg 1: Argument tuple (args) */ /* Reg 2: Argument count (argn) */ /* Reg 3: Jump flag (jump?) */ /* Reg 4: Loop iterator (i) */ /* Reg 5: Loop values (x) */ uint32_t apply_asm[] = { SS(JOP_LENGTH, 2, 1), SSS(JOP_EQUALS_IMMEDIATE, 3, 2, 0), /* Immediate tail call if no args */ SI(JOP_JUMP_IF, 3, 9), /* Prime loop */ SI(JOP_LOAD_INTEGER, 4, 0), /* i = 0 */ /* Main loop */ SSS(JOP_IN, 5, 1, 4), /* x = args[i] */ SSI(JOP_ADD_IMMEDIATE, 4, 4, 1), /* i++ */ SSI(JOP_EQUALS, 3, 4, 2), /* jump? = (i == argn) */ SI(JOP_JUMP_IF, 3, 3), /* if jump? go forward 3 */ S(JOP_PUSH, 5), (JOP_JUMP | ((uint32_t)(-5) << 8)), /* Push the array */ S(JOP_PUSH_ARRAY, 5), /* Call the function */ S(JOP_TAILCALL, 0) }; janet_quick_asm(env, JANET_FUN_APPLY | JANET_FUNCDEF_FLAG_VARARG, "apply", 1, 1, INT32_MAX, 6, apply_asm, sizeof(apply_asm), JDOC("(apply f & args)\n\n" "Applies a function f to a variable number of arguments. Each " "element in args is used as an argument to f, except the last " "element in args, which is expected to be an array or a tuple. " "Each element in this last argument is then also pushed as an " "argument to f.")); } static const uint32_t error_asm[] = { JOP_ERROR }; static const uint32_t debug_asm[] = { JOP_SIGNAL | (2 << 24), JOP_RETURN }; static const uint32_t yield_asm[] = { JOP_SIGNAL | (3 << 24), JOP_RETURN }; static const uint32_t resume_asm[] = { JOP_RESUME | (1 << 24), JOP_RETURN }; static const uint32_t cancel_asm[] = { JOP_CANCEL | (1 << 24), JOP_RETURN }; static const uint32_t in_asm[] = { JOP_IN | (1 << 24), JOP_LOAD_NIL | (3 << 8), JOP_EQUALS | (3 << 8) | (3 << 24), JOP_JUMP_IF | (3 << 8) | (2 << 16), JOP_RETURN, JOP_RETURN | (2 << 8) }; static const uint32_t get_asm[] = { JOP_GET | (1 << 24), JOP_LOAD_NIL | (3 << 8), JOP_EQUALS | (3 << 8) | (3 << 24), JOP_JUMP_IF | (3 << 8) | (2 << 16), JOP_RETURN, JOP_RETURN | (2 << 8) }; static const uint32_t put_asm[] = { JOP_PUT | (1 << 16) | (2 << 24), JOP_RETURN }; static const uint32_t length_asm[] = { JOP_LENGTH, JOP_RETURN }; static const uint32_t bnot_asm[] = { JOP_BNOT, JOP_RETURN }; static const uint32_t propagate_asm[] = { JOP_PROPAGATE | (1 << 24), JOP_RETURN }; static const uint32_t next_asm[] = { JOP_NEXT | (1 << 24), JOP_RETURN }; static const uint32_t cmp_asm[] = { JOP_COMPARE | (1 << 24), JOP_RETURN }; #endif /* ifdef JANET_BOOTSTRAP */ /* * Setup Environment */ static void janet_load_libs(JanetTable *env) { JanetRegExt corelib_cfuns[] = { JANET_CORE_REG("native", janet_core_native), JANET_CORE_REG("describe", janet_core_describe), JANET_CORE_REG("string", janet_core_string), JANET_CORE_REG("symbol", janet_core_symbol), JANET_CORE_REG("keyword", janet_core_keyword), JANET_CORE_REG("buffer", janet_core_buffer), JANET_CORE_REG("abstract?", janet_core_is_abstract), JANET_CORE_REG("table", janet_core_table), JANET_CORE_REG("array", janet_core_array), JANET_CORE_REG("scan-number", janet_core_scannumber), JANET_CORE_REG("tuple", janet_core_tuple), JANET_CORE_REG("struct", janet_core_struct), JANET_CORE_REG("gensym", janet_core_gensym), JANET_CORE_REG("gccollect", janet_core_gccollect), JANET_CORE_REG("gcsetinterval", janet_core_gcsetinterval), JANET_CORE_REG("gcinterval", janet_core_gcinterval), JANET_CORE_REG("type", janet_core_type), JANET_CORE_REG("hash", janet_core_hash), JANET_CORE_REG("getline", janet_core_getline), JANET_CORE_REG("dyn", janet_core_dyn), JANET_CORE_REG("setdyn", janet_core_setdyn), JANET_CORE_REG("trace", janet_core_trace), JANET_CORE_REG("untrace", janet_core_untrace), JANET_CORE_REG("module/expand-path", janet_core_expand_path), JANET_CORE_REG("int?", janet_core_check_int), JANET_CORE_REG("nat?", janet_core_check_nat), JANET_CORE_REG("bytes?", janet_core_is_bytes), JANET_CORE_REG("indexed?", janet_core_is_indexed), JANET_CORE_REG("dictionary?", janet_core_is_dictionary), JANET_CORE_REG("lengthable?", janet_core_is_lengthable), JANET_CORE_REG("slice", janet_core_slice), JANET_CORE_REG("range", janet_core_range), JANET_CORE_REG("signal", janet_core_signal), JANET_CORE_REG("memcmp", janet_core_memcmp), JANET_CORE_REG("getproto", janet_core_getproto), JANET_CORE_REG("sandbox", janet_core_sandbox), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, corelib_cfuns); janet_lib_io(env); janet_lib_math(env); janet_lib_array(env); janet_lib_tuple(env); janet_lib_buffer(env); janet_lib_table(env); janet_lib_struct(env); janet_lib_fiber(env); janet_lib_os(env); janet_lib_parse(env); janet_lib_compile(env); janet_lib_debug(env); janet_lib_string(env); janet_lib_marsh(env); #ifdef JANET_PEG janet_lib_peg(env); #endif #ifdef JANET_ASSEMBLER janet_lib_asm(env); #endif #ifdef JANET_INT_TYPES janet_lib_inttypes(env); #endif #ifdef JANET_EV janet_lib_ev(env); #ifdef JANET_FILEWATCH janet_lib_filewatch(env); #endif #endif #ifdef JANET_NET janet_lib_net(env); #endif #ifdef JANET_FFI janet_lib_ffi(env); #endif } #ifdef JANET_BOOTSTRAP JanetTable *janet_core_env(JanetTable *replacements) { JanetTable *env = (NULL != replacements) ? replacements : janet_table(0); janet_quick_asm(env, JANET_FUN_CMP, "cmp", 2, 2, 2, 2, cmp_asm, sizeof(cmp_asm), JDOC("(cmp x y)\n\n" "Returns -1 if x is strictly less than y, 1 if y is strictly greater " "than x, and 0 otherwise. To return 0, x and y must be the exact same type.")); janet_quick_asm(env, JANET_FUN_NEXT, "next", 2, 1, 2, 2, next_asm, sizeof(next_asm), JDOC("(next ds &opt key)\n\n" "Gets the next key in a data structure. Can be used to iterate through " "the keys of a data structure in an unspecified order. Keys are guaranteed " "to be seen only once per iteration if the data structure is not mutated " "during iteration. If key is nil, next returns the first key. If next " "returns nil, there are no more keys to iterate through.")); janet_quick_asm(env, JANET_FUN_PROP, "propagate", 2, 2, 2, 2, propagate_asm, sizeof(propagate_asm), JDOC("(propagate x fiber)\n\n" "Propagate a signal from a fiber to the current fiber and " "set the last value of the current fiber to `x`. The signal " "value is then available as the status of the current fiber. " "The resulting stack trace from the current fiber will include " "frames from fiber. If fiber is in a state that can be resumed, " "resuming the current fiber will first resume `fiber`. " "This function can be used to re-raise an error without losing " "the original stack trace.")); janet_quick_asm(env, JANET_FUN_DEBUG, "debug", 1, 0, 1, 1, debug_asm, sizeof(debug_asm), JDOC("(debug &opt x)\n\n" "Throws a debug signal that can be caught by a parent fiber and used to inspect " "the running state of the current fiber. Returns the value passed in by resume.")); janet_quick_asm(env, JANET_FUN_ERROR, "error", 1, 1, 1, 1, error_asm, sizeof(error_asm), JDOC("(error e)\n\n" "Throws an error e that can be caught and handled by a parent fiber.")); janet_quick_asm(env, JANET_FUN_YIELD, "yield", 1, 0, 1, 2, yield_asm, sizeof(yield_asm), JDOC("(yield &opt x)\n\n" "Yield a value to a parent fiber. When a fiber yields, its execution is paused until " "another thread resumes it. The fiber will then resume, and the last yield call will " "return the value that was passed to resume.")); janet_quick_asm(env, JANET_FUN_CANCEL, "cancel", 2, 2, 2, 2, cancel_asm, sizeof(cancel_asm), JDOC("(cancel fiber err)\n\n" "Resume a fiber but have it immediately raise an error. This lets a programmer unwind a pending fiber. " "Returns the same result as resume.")); janet_quick_asm(env, JANET_FUN_RESUME, "resume", 2, 1, 2, 2, resume_asm, sizeof(resume_asm), JDOC("(resume fiber &opt x)\n\n" "Resume a new or suspended fiber and optionally pass in a value to the fiber that " "will be returned to the last yield in the case of a pending fiber, or the argument to " "the dispatch function in the case of a new fiber. Returns either the return result of " "the fiber's dispatch function, or the value from the next yield call in fiber.")); janet_quick_asm(env, JANET_FUN_IN, "in", 3, 2, 3, 4, in_asm, sizeof(in_asm), JDOC("(in ds key &opt dflt)\n\n" "Get value in ds at key, works on associative data structures. Arrays, tuples, tables, structs, " "strings, symbols, and buffers are all associative and can be used. Arrays, tuples, strings, buffers, " "and symbols must use integer keys that are in bounds or an error is raised. Structs and tables can " "take any value as a key except nil and will return nil or dflt if not found.")); janet_quick_asm(env, JANET_FUN_GET, "get", 3, 2, 3, 4, get_asm, sizeof(in_asm), JDOC("(get ds key &opt dflt)\n\n" "Get the value mapped to key in data structure ds, and return dflt or nil if not found. " "Similar to in, but will not throw an error if the key is invalid for the data structure " "unless the data structure is an abstract type. In that case, the abstract type getter may throw " "an error.")); janet_quick_asm(env, JANET_FUN_PUT, "put", 3, 3, 3, 3, put_asm, sizeof(put_asm), JDOC("(put ds key value)\n\n" "Associate a key with a value in any mutable associative data structure. Indexed data structures " "(arrays and buffers) only accept non-negative integer keys, and will expand if an out of bounds " "value is provided. In an array, extra space will be filled with nils, and in a buffer, extra " "space will be filled with 0 bytes. In a table, putting a key that is contained in the table prototype " "will hide the association defined by the prototype, but will not mutate the prototype table. Putting " "a value nil into a table will remove the key from the table. Returns the data structure ds.")); janet_quick_asm(env, JANET_FUN_LENGTH, "length", 1, 1, 1, 1, length_asm, sizeof(length_asm), JDOC("(length ds)\n\n" "Returns the length or count of a data structure in constant time as an integer. For " "structs and tables, returns the number of key-value pairs in the data structure.")); janet_quick_asm(env, JANET_FUN_BNOT, "bnot", 1, 1, 1, 1, bnot_asm, sizeof(bnot_asm), JDOC("(bnot x)\n\nReturns the bit-wise inverse of integer x.")); make_apply(env); /* Variadic ops */ templatize_varop(env, JANET_FUN_ADD, "+", 0, 0, JOP_ADD, JDOC("(+ & xs)\n\n" "Returns the sum of all xs. If xs is empty, return 0.")); templatize_varop(env, JANET_FUN_SUBTRACT, "-", 0, 0, JOP_SUBTRACT, JDOC("(- & xs)\n\n" "Returns the difference of xs. If xs is empty, returns 0. If xs has one element, returns the " "negative value of that element. Otherwise, returns the first element in xs minus the sum of " "the rest of the elements.")); templatize_varop(env, JANET_FUN_MULTIPLY, "*", 1, 1, JOP_MULTIPLY, JDOC("(* & xs)\n\n" "Returns the product of all elements in xs. If xs is empty, returns 1.")); templatize_varop(env, JANET_FUN_DIVIDE, "/", 1, 1, JOP_DIVIDE, JDOC("(/ & xs)\n\n" "Returns the quotient of xs. If xs is empty, returns 1. If xs has one value x, returns " "the reciprocal of x. Otherwise return the first value of xs repeatedly divided by the remaining " "values.")); templatize_varop(env, JANET_FUN_DIVIDE_FLOOR, "div", 1, 1, JOP_DIVIDE_FLOOR, JDOC("(div & xs)\n\n" "Returns the floored division of xs. If xs is empty, returns 1. If xs has one value x, returns " "the reciprocal of x. Otherwise return the first value of xs repeatedly divided by the remaining " "values.")); templatize_varop(env, JANET_FUN_MODULO, "mod", 0, 1, JOP_MODULO, JDOC("(mod & xs)\n\n" "Returns the result of applying the modulo operator on the first value of xs with each remaining value. " "`(mod x 0)` is defined to be `x`.")); templatize_varop(env, JANET_FUN_REMAINDER, "%", 0, 1, JOP_REMAINDER, JDOC("(% & xs)\n\n" "Returns the remainder of dividing the first value of xs by each remaining value.")); templatize_varop(env, JANET_FUN_BAND, "band", -1, -1, JOP_BAND, JDOC("(band & xs)\n\n" "Returns the bit-wise and of all values in xs. Each x in xs must be an integer.")); templatize_varop(env, JANET_FUN_BOR, "bor", 0, 0, JOP_BOR, JDOC("(bor & xs)\n\n" "Returns the bit-wise or of all values in xs. Each x in xs must be an integer.")); templatize_varop(env, JANET_FUN_BXOR, "bxor", 0, 0, JOP_BXOR, JDOC("(bxor & xs)\n\n" "Returns the bit-wise xor of all values in xs. Each x in xs must be an integer.")); templatize_varop(env, JANET_FUN_LSHIFT, "blshift", 1, 1, JOP_SHIFT_LEFT, JDOC("(blshift x & shifts)\n\n" "Returns the value of x bit shifted left by the sum of all values in shifts. x " "and each element in shift must be an integer.")); templatize_varop(env, JANET_FUN_RSHIFT, "brshift", 1, 1, JOP_SHIFT_RIGHT, JDOC("(brshift x & shifts)\n\n" "Returns the value of x bit shifted right by the sum of all values in shifts. x " "and each element in shift must be an integer.")); templatize_varop(env, JANET_FUN_RSHIFTU, "brushift", 1, 1, JOP_SHIFT_RIGHT_UNSIGNED, JDOC("(brushift x & shifts)\n\n" "Returns the value of x bit shifted right by the sum of all values in shifts. x " "and each element in shift must be an integer. The sign of x is not preserved, so " "for positive shifts the return value will always be positive.")); /* Variadic comparators */ templatize_comparator(env, JANET_FUN_GT, ">", 0, JOP_GREATER_THAN, JDOC("(> & xs)\n\n" "Check if xs is in descending order. Returns a boolean.")); templatize_comparator(env, JANET_FUN_LT, "<", 0, JOP_LESS_THAN, JDOC("(< & xs)\n\n" "Check if xs is in ascending order. Returns a boolean.")); templatize_comparator(env, JANET_FUN_GTE, ">=", 0, JOP_GREATER_THAN_EQUAL, JDOC("(>= & xs)\n\n" "Check if xs is in non-ascending order. Returns a boolean.")); templatize_comparator(env, JANET_FUN_LTE, "<=", 0, JOP_LESS_THAN_EQUAL, JDOC("(<= & xs)\n\n" "Check if xs is in non-descending order. Returns a boolean.")); templatize_comparator(env, JANET_FUN_EQ, "=", 0, JOP_EQUALS, JDOC("(= & xs)\n\n" "Check if all values in xs are equal. Returns a boolean.")); templatize_comparator(env, JANET_FUN_NEQ, "not=", 1, JOP_EQUALS, JDOC("(not= & xs)\n\n" "Check if any values in xs are not equal. Returns a boolean.")); /* Platform detection */ janet_def(env, "janet/version", janet_cstringv(JANET_VERSION), JDOC("The version number of the running janet program.")); janet_def(env, "janet/build", janet_cstringv(JANET_BUILD), JDOC("The build identifier of the running janet program.")); janet_def(env, "janet/config-bits", janet_wrap_integer(JANET_CURRENT_CONFIG_BITS), JDOC("The flag set of config options from janetconf.h which is used to check " "if native modules are compatible with the host program.")); /* Allow references to the environment */ janet_def(env, "root-env", janet_wrap_table(env), JDOC("The root environment used to create environments with (make-env).")); janet_load_libs(env); janet_gcroot(janet_wrap_table(env)); return env; } #else JanetTable *janet_core_env(JanetTable *replacements) { /* Memoize core env, ignoring replacements the second time around. */ if (NULL != janet_vm.core_env) { return janet_vm.core_env; } JanetTable *dict = janet_core_lookup_table(replacements); /* Unmarshal bytecode */ Janet marsh_out = janet_unmarshal( janet_core_image, janet_core_image_size, 0, dict, NULL); /* Memoize */ janet_gcroot(marsh_out); JanetTable *env = janet_unwrap_table(marsh_out); janet_vm.core_env = env; /* Invert image dict manually here. We can't do this in boot.janet as it * breaks deterministic builds */ Janet lidv, midv; lidv = midv = janet_wrap_nil(); janet_resolve(env, janet_csymbol("load-image-dict"), &lidv); janet_resolve(env, janet_csymbol("make-image-dict"), &midv); /* Check that we actually got tables - if we are using a smaller corelib, may not exist */ if (janet_checktype(lidv, JANET_TABLE) && janet_checktype(midv, JANET_TABLE)) { JanetTable *lid = janet_unwrap_table(lidv); JanetTable *mid = janet_unwrap_table(midv); for (int32_t i = 0; i < lid->capacity; i++) { const JanetKV *kv = lid->data + i; if (!janet_checktype(kv->key, JANET_NIL)) { janet_table_put(mid, kv->value, kv->key); } } } return env; } #endif JanetTable *janet_core_lookup_table(JanetTable *replacements) { JanetTable *dict = janet_table(512); janet_load_libs(dict); /* Add replacements */ if (replacements != NULL) { for (int32_t i = 0; i < replacements->capacity; i++) { JanetKV kv = replacements->data[i]; if (!janet_checktype(kv.key, JANET_NIL)) { janet_table_put(dict, kv.key, kv.value); /* Add replacement functions to registry? */ } } } return dict; } janet-1.41.2/src/core/debug.c000066400000000000000000000441471514534607600156760ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "gc.h" #include "state.h" #include "util.h" #include "vector.h" #endif /* Implements functionality to build a debugger from within janet. * The repl should also be able to serve as pretty featured debugger * out of the box. */ /* Add a break point to a function */ void janet_debug_break(JanetFuncDef *def, int32_t pc) { if (pc >= def->bytecode_length || pc < 0) janet_panic("invalid bytecode offset"); def->bytecode[pc] |= 0x80; } /* Remove a break point from a function */ void janet_debug_unbreak(JanetFuncDef *def, int32_t pc) { if (pc >= def->bytecode_length || pc < 0) janet_panic("invalid bytecode offset"); def->bytecode[pc] &= ~((uint32_t)0x80); } /* * Find a location for a breakpoint given a source file an * location. */ void janet_debug_find( JanetFuncDef **def_out, int32_t *pc_out, const uint8_t *source, int32_t sourceLine, int32_t sourceColumn) { /* Scan the heap for right func def */ JanetGCObject *current = janet_vm.blocks; /* Keep track of the best source mapping we have seen so far */ int32_t besti = -1; int32_t best_line = -1; int32_t best_column = -1; JanetFuncDef *best_def = NULL; while (NULL != current) { if ((current->flags & JANET_MEM_TYPEBITS) == JANET_MEMORY_FUNCDEF) { JanetFuncDef *def = (JanetFuncDef *)(current); if (def->sourcemap && def->source && !janet_string_compare(source, def->source)) { /* Correct source file, check mappings. The chosen * pc index is the instruction closest to the given line column, but * not after. */ int32_t i; for (i = 0; i < def->bytecode_length; i++) { int32_t line = def->sourcemap[i].line; int32_t column = def->sourcemap[i].column; if (line <= sourceLine && line >= best_line) { if (column <= sourceColumn && (line > best_line || column > best_column)) { best_line = line; best_column = column; besti = i; best_def = def; } } } } } current = current->data.next; } if (best_def) { *def_out = best_def; *pc_out = besti; } else { janet_panic("could not find breakpoint"); } } void janet_stacktrace(JanetFiber *fiber, Janet err) { const char *prefix = janet_checktype(err, JANET_NIL) ? NULL : ""; janet_stacktrace_ext(fiber, err, prefix); } /* Error reporting. This can be emulated from within Janet, but for * consistency with the top level code it is defined once. */ void janet_stacktrace_ext(JanetFiber *fiber, Janet err, const char *prefix) { int32_t fi; const char *errstr = (const char *)janet_to_string(err); JanetFiber **fibers = NULL; int wrote_error = !prefix; int print_color = janet_truthy(janet_dyn("err-color")); if (print_color) janet_eprintf("\x1b[31m"); while (fiber) { janet_v_push(fibers, fiber); fiber = fiber->child; } for (fi = janet_v_count(fibers) - 1; fi >= 0; fi--) { fiber = fibers[fi]; int32_t i = fiber->frame; while (i > 0) { JanetCFunRegistry *reg = NULL; JanetStackFrame *frame = (JanetStackFrame *)(fiber->data + i - JANET_FRAME_SIZE); JanetFuncDef *def = NULL; i = frame->prevframe; /* Print prelude to stack frame */ if (!wrote_error) { JanetFiberStatus status = janet_fiber_status(fiber); janet_eprintf("%s%s: %s\n", prefix ? prefix : "", janet_status_names[status], errstr ? errstr : janet_status_names[status]); wrote_error = 1; } janet_eprintf(" in"); if (frame->func) { def = frame->func->def; janet_eprintf(" %s", def->name ? (const char *)def->name : ""); if (def->source) { janet_eprintf(" [%s]", (const char *)def->source); } } else { JanetCFunction cfun = (JanetCFunction)(frame->pc); if (cfun) { reg = janet_registry_get(cfun); if (NULL != reg && NULL != reg->name) { if (reg->name_prefix) { janet_eprintf(" %s/%s", reg->name_prefix, reg->name); } else { janet_eprintf(" %s", reg->name); } if (NULL != reg->source_file) { janet_eprintf(" [%s]", reg->source_file); } } else { janet_eprintf(" "); } } } if (frame->flags & JANET_STACKFRAME_TAILCALL) janet_eprintf(" (tail call)"); if (frame->func && frame->pc) { int32_t off = (int32_t)(frame->pc - def->bytecode); if (def->sourcemap) { JanetSourceMapping mapping = def->sourcemap[off]; janet_eprintf(" on line %d, column %d", mapping.line, mapping.column); } else { janet_eprintf(" pc=%d", off); } } else if (NULL != reg) { /* C Function */ if (reg->source_line > 0) { janet_eprintf(" on line %d", (long) reg->source_line); } } janet_eprintf("\n"); /* Print fiber points optionally. Clutters traces but provides info if (i <= 0 && fi > 0) { janet_eprintf(" in parent fiber\n"); } */ } } if (print_color) janet_eprintf("\x1b[0m"); janet_v_free(fibers); } /* * CFuns */ /* Helper to find funcdef and bytecode offset to insert or remove breakpoints. * Takes a source file name and byte offset. */ static void helper_find(int32_t argc, Janet *argv, JanetFuncDef **def, int32_t *bytecode_offset) { janet_fixarity(argc, 3); const uint8_t *source = janet_getstring(argv, 0); int32_t line = janet_getinteger(argv, 1); int32_t col = janet_getinteger(argv, 2); janet_debug_find(def, bytecode_offset, source, line, col); } /* Helper to find funcdef and bytecode offset to insert or remove breakpoints. * Takes a function and byte offset*/ static void helper_find_fun(int32_t argc, Janet *argv, JanetFuncDef **def, int32_t *bytecode_offset) { janet_arity(argc, 1, 2); JanetFunction *func = janet_getfunction(argv, 0); int32_t offset = (argc == 2) ? janet_getinteger(argv, 1) : 0; *def = func->def; *bytecode_offset = offset; } JANET_CORE_FN(cfun_debug_break, "(debug/break source line col)", "Sets a breakpoint in `source` at a given line and column. " "Will throw an error if the breakpoint location " "cannot be found. For example\n\n" "\t(debug/break \"core.janet\" 10 4)\n\n" "will set a breakpoint at line 10, 4th column of the file core.janet.") { JanetFuncDef *def; int32_t offset; helper_find(argc, argv, &def, &offset); janet_debug_break(def, offset); return janet_wrap_nil(); } JANET_CORE_FN(cfun_debug_unbreak, "(debug/unbreak source line column)", "Remove a breakpoint with a source key at a given line and column. " "Will throw an error if the breakpoint " "cannot be found.") { JanetFuncDef *def; int32_t offset = 0; helper_find(argc, argv, &def, &offset); janet_debug_unbreak(def, offset); return janet_wrap_nil(); } JANET_CORE_FN(cfun_debug_fbreak, "(debug/fbreak fun &opt pc)", "Set a breakpoint in a given function. pc is an optional offset, which " "is in bytecode instructions. fun is a function value. Will throw an error " "if the offset is too large or negative.") { JanetFuncDef *def; int32_t offset = 0; helper_find_fun(argc, argv, &def, &offset); janet_debug_break(def, offset); return janet_wrap_nil(); } JANET_CORE_FN(cfun_debug_unfbreak, "(debug/unfbreak fun &opt pc)", "Unset a breakpoint set with debug/fbreak.") { JanetFuncDef *def; int32_t offset; helper_find_fun(argc, argv, &def, &offset); janet_debug_unbreak(def, offset); return janet_wrap_nil(); } JANET_CORE_FN(cfun_debug_lineage, "(debug/lineage fib)", "Returns an array of all child fibers from a root fiber. This function " "is useful when a fiber signals or errors to an ancestor fiber. Using this function, " "the fiber handling the error can see which fiber raised the signal. This function should " "be used mostly for debugging purposes.") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); JanetArray *array = janet_array(0); while (fiber) { janet_array_push(array, janet_wrap_fiber(fiber)); fiber = fiber->child; } return janet_wrap_array(array); } /* Extract info from one stack frame */ static Janet doframe(JanetStackFrame *frame) { int32_t off; JanetTable *t = janet_table(3); JanetFuncDef *def = NULL; if (frame->func) { janet_table_put(t, janet_ckeywordv("function"), janet_wrap_function(frame->func)); def = frame->func->def; if (def->name) { janet_table_put(t, janet_ckeywordv("name"), janet_wrap_string(def->name)); } } else { JanetCFunction cfun = (JanetCFunction)(frame->pc); if (cfun) { JanetCFunRegistry *reg = janet_registry_get(cfun); if (NULL != reg->name) { if (NULL != reg->name_prefix) { janet_table_put(t, janet_ckeywordv("name"), janet_wrap_string(janet_formatc("%s/%s", reg->name_prefix, reg->name))); } else { janet_table_put(t, janet_ckeywordv("name"), janet_cstringv(reg->name)); } if (NULL != reg->source_file) { janet_table_put(t, janet_ckeywordv("source"), janet_cstringv(reg->source_file)); } if (reg->source_line > 0) { janet_table_put(t, janet_ckeywordv("source-line"), janet_wrap_integer(reg->source_line)); janet_table_put(t, janet_ckeywordv("source-column"), janet_wrap_integer(1)); } } } janet_table_put(t, janet_ckeywordv("c"), janet_wrap_true()); } if (frame->flags & JANET_STACKFRAME_TAILCALL) { janet_table_put(t, janet_ckeywordv("tail"), janet_wrap_true()); } if (frame->func && frame->pc) { Janet *stack = (Janet *)frame + JANET_FRAME_SIZE; JanetArray *slots; janet_assert(def != NULL, "def != NULL"); off = (int32_t)(frame->pc - def->bytecode); janet_table_put(t, janet_ckeywordv("pc"), janet_wrap_integer(off)); if (def->sourcemap) { JanetSourceMapping mapping = def->sourcemap[off]; janet_table_put(t, janet_ckeywordv("source-line"), janet_wrap_integer(mapping.line)); janet_table_put(t, janet_ckeywordv("source-column"), janet_wrap_integer(mapping.column)); } if (def->source) { janet_table_put(t, janet_ckeywordv("source"), janet_wrap_string(def->source)); } /* Add stack arguments */ slots = janet_array(def->slotcount); safe_memcpy(slots->data, stack, sizeof(Janet) * def->slotcount); slots->count = def->slotcount; janet_table_put(t, janet_ckeywordv("slots"), janet_wrap_array(slots)); /* Add local bindings */ if (def->symbolmap) { JanetTable *local_bindings = janet_table(0); for (int32_t i = def->symbolmap_length - 1; i >= 0; i--) { JanetSymbolMap jsm = def->symbolmap[i]; Janet value = janet_wrap_nil(); uint32_t pc = (uint32_t)(frame->pc - def->bytecode); if (jsm.birth_pc == UINT32_MAX) { JanetFuncEnv *env = frame->func->envs[jsm.death_pc]; if (env->offset > 0) { value = env->as.fiber->data[env->offset + jsm.slot_index]; } else { value = env->as.values[jsm.slot_index]; } } else if (pc >= jsm.birth_pc && pc < jsm.death_pc) { value = stack[jsm.slot_index]; } janet_table_put(local_bindings, janet_wrap_symbol(jsm.symbol), value); } janet_table_put(t, janet_ckeywordv("locals"), janet_wrap_table(local_bindings)); } } return janet_wrap_table(t); } JANET_CORE_FN(cfun_debug_stack, "(debug/stack fib)", "Gets information about the stack as an array of tables. Each table " "in the array contains information about a stack frame. The top-most, current " "stack frame is the first table in the array, and the bottom-most stack frame " "is the last value. Each stack frame contains some of the following attributes:\n\n" "* :c - true if the stack frame is a c function invocation\n\n" "* :source-column - the current source column of the stack frame\n\n" "* :function - the function that the stack frame represents\n\n" "* :source-line - the current source line of the stack frame\n\n" "* :name - the human-friendly name of the function\n\n" "* :pc - integer indicating the location of the program counter\n\n" "* :source - string with the file path or other identifier for the source code\n\n" "* :slots - array of all values in each slot\n\n" "* :tail - boolean indicating a tail call") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); JanetArray *array = janet_array(0); { int32_t i = fiber->frame; JanetStackFrame *frame; while (i > 0) { frame = (JanetStackFrame *)(fiber->data + i - JANET_FRAME_SIZE); janet_array_push(array, doframe(frame)); i = frame->prevframe; } } return janet_wrap_array(array); } JANET_CORE_FN(cfun_debug_stacktrace, "(debug/stacktrace fiber &opt err prefix)", "Prints a nice looking stacktrace for a fiber. Can optionally provide " "an error value to print the stack trace with. If `prefix` is nil or not " "provided, will skip the error line. Returns the fiber.") { janet_arity(argc, 1, 3); JanetFiber *fiber = janet_getfiber(argv, 0); Janet x = argc == 1 ? janet_wrap_nil() : argv[1]; const char *prefix = janet_optcstring(argv, argc, 2, NULL); janet_stacktrace_ext(fiber, x, prefix); return argv[0]; } JANET_CORE_FN(cfun_debug_argstack, "(debug/arg-stack fiber)", "Gets all values currently on the fiber's argument stack. Normally, " "this should be empty unless the fiber signals while pushing arguments " "to make a function call. Returns a new array.") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); JanetArray *array = janet_array(fiber->stacktop - fiber->stackstart); memcpy(array->data, fiber->data + fiber->stackstart, array->capacity * sizeof(Janet)); array->count = array->capacity; return janet_wrap_array(array); } JANET_CORE_FN(cfun_debug_step, "(debug/step fiber &opt x)", "Run a fiber for one virtual instruction of the Janet machine. Can optionally " "pass in a value that will be passed as the resuming value. Returns the signal value, " "which will usually be nil, as breakpoints raise nil signals.") { janet_arity(argc, 1, 2); JanetFiber *fiber = janet_getfiber(argv, 0); Janet out = janet_wrap_nil(); janet_step(fiber, argc == 1 ? janet_wrap_nil() : argv[1], &out); return out; } /* Module entry point */ void janet_lib_debug(JanetTable *env) { JanetRegExt debug_cfuns[] = { JANET_CORE_REG("debug/break", cfun_debug_break), JANET_CORE_REG("debug/unbreak", cfun_debug_unbreak), JANET_CORE_REG("debug/fbreak", cfun_debug_fbreak), JANET_CORE_REG("debug/unfbreak", cfun_debug_unfbreak), JANET_CORE_REG("debug/arg-stack", cfun_debug_argstack), JANET_CORE_REG("debug/stack", cfun_debug_stack), JANET_CORE_REG("debug/stacktrace", cfun_debug_stacktrace), JANET_CORE_REG("debug/lineage", cfun_debug_lineage), JANET_CORE_REG("debug/step", cfun_debug_step), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, debug_cfuns); } janet-1.41.2/src/core/emit.c000066400000000000000000000277731514534607600155540ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "emit.h" #include "vector.h" #include "regalloc.h" #include "util.h" #endif /* Get a register */ int32_t janetc_allocfar(JanetCompiler *c) { int32_t reg = janetc_regalloc_1(&c->scope->ra); if (reg > 0xFFFF) { janetc_cerror(c, "ran out of internal registers"); } return reg; } /* Get a register less than 256 for temporary use. */ int32_t janetc_allocnear(JanetCompiler *c, JanetcRegisterTemp tag) { return janetc_regalloc_temp(&c->scope->ra, tag); } /* Emit a raw instruction with source mapping. */ void janetc_emit(JanetCompiler *c, uint32_t instr) { janet_v_push(c->buffer, instr); janet_v_push(c->mapbuffer, c->current_mapping); } /* Add a constant to the current scope. Return the index of the constant. */ static int32_t janetc_const(JanetCompiler *c, Janet x) { JanetScope *scope = c->scope; int32_t i, len; /* Get the topmost function scope */ while (scope) { if (scope->flags & JANET_SCOPE_FUNCTION) break; scope = scope->parent; } /* Check if already added */ len = janet_v_count(scope->consts); for (i = 0; i < len; i++) { if (janet_equals(x, scope->consts[i])) return i; } /* Ensure not too many constants. */ if (len >= 0xFFFF) { janetc_cerror(c, "too many constants"); return 0; } janet_v_push(scope->consts, x); return len; } /* Load a constant into a local register */ static void janetc_loadconst(JanetCompiler *c, Janet k, int32_t reg) { switch (janet_type(k)) { case JANET_NIL: janetc_emit(c, (reg << 8) | JOP_LOAD_NIL); break; case JANET_BOOLEAN: janetc_emit(c, (reg << 8) | (janet_unwrap_boolean(k) ? JOP_LOAD_TRUE : JOP_LOAD_FALSE)); break; case JANET_NUMBER: { double dval = janet_unwrap_number(k); if (dval < INT16_MIN || dval > INT16_MAX) goto do_constant; int32_t i = (int32_t) dval; if (dval != i) goto do_constant; uint32_t iu = (uint32_t)i; janetc_emit(c, (iu << 16) | (reg << 8) | JOP_LOAD_INTEGER); break; } default: do_constant: { int32_t cindex = janetc_const(c, k); janetc_emit(c, (cindex << 16) | (reg << 8) | JOP_LOAD_CONSTANT); break; } } } /* Move a slot to a near register */ static void janetc_movenear(JanetCompiler *c, int32_t dest, JanetSlot src) { if (src.flags & (JANET_SLOT_CONSTANT | JANET_SLOT_REF)) { janetc_loadconst(c, src.constant, dest); /* If we also are a reference, deref the one element array */ if (src.flags & JANET_SLOT_REF) { janetc_emit(c, (dest << 16) | (dest << 8) | JOP_GET_INDEX); } } else if (src.envindex >= 0) { janetc_emit(c, ((uint32_t)(src.index) << 24) | ((uint32_t)(src.envindex) << 16) | ((uint32_t)(dest) << 8) | JOP_LOAD_UPVALUE); } else if (src.index != dest) { janet_assert(src.index >= 0, "bad slot"); janetc_emit(c, ((uint32_t)(src.index) << 16) | ((uint32_t)(dest) << 8) | JOP_MOVE_NEAR); } } /* Move a near register to a Slot. */ static void janetc_moveback(JanetCompiler *c, JanetSlot dest, int32_t src) { if (dest.flags & JANET_SLOT_REF) { int32_t refreg = janetc_regalloc_temp(&c->scope->ra, JANETC_REGTEMP_5); janetc_loadconst(c, dest.constant, refreg); janetc_emit(c, (src << 16) | (refreg << 8) | JOP_PUT_INDEX); janetc_regalloc_freetemp(&c->scope->ra, refreg, JANETC_REGTEMP_5); } else if (dest.envindex >= 0) { janetc_emit(c, ((uint32_t)(dest.index) << 24) | ((uint32_t)(dest.envindex) << 16) | ((uint32_t)(src) << 8) | JOP_SET_UPVALUE); } else if (dest.index != src) { janet_assert(dest.index >= 0, "bad slot"); janetc_emit(c, ((uint32_t)(dest.index) << 16) | ((uint32_t)(src) << 8) | JOP_MOVE_FAR); } } /* Call this to release a register after emitting the instruction. */ static void janetc_free_regnear(JanetCompiler *c, JanetSlot s, int32_t reg, JanetcRegisterTemp tag) { if (reg != s.index || s.envindex >= 0 || s.flags & (JANET_SLOT_CONSTANT | JANET_SLOT_REF)) { /* We need to free the temporary slot */ janetc_regalloc_freetemp(&c->scope->ra, reg, tag); } } /* Convert a slot to a two byte register */ static int32_t janetc_regfar(JanetCompiler *c, JanetSlot s, JanetcRegisterTemp tag) { /* check if already near register */ if (s.envindex < 0 && s.index >= 0) { return s.index; } int32_t reg; int32_t nearreg = janetc_regalloc_temp(&c->scope->ra, tag); janetc_movenear(c, nearreg, s); if (nearreg >= 0xF0) { reg = janetc_allocfar(c); janetc_emit(c, JOP_MOVE_FAR | (nearreg << 8) | (reg << 16)); janetc_regalloc_freetemp(&c->scope->ra, nearreg, tag); } else { reg = nearreg; janetc_regalloc_freetemp(&c->scope->ra, nearreg, tag); janetc_regalloc_touch(&c->scope->ra, reg); } return reg; } /* Convert a slot to a temporary 1 byte register */ static int32_t janetc_regnear(JanetCompiler *c, JanetSlot s, JanetcRegisterTemp tag) { /* check if already near register */ if (s.envindex < 0 && s.index >= 0 && s.index <= 0xFF) { return s.index; } int32_t reg = janetc_regalloc_temp(&c->scope->ra, tag); janetc_movenear(c, reg, s); return reg; } /* Check if two slots are equal */ int janetc_sequal(JanetSlot lhs, JanetSlot rhs) { if ((lhs.flags & ~JANET_SLOTTYPE_ANY) == (rhs.flags & ~JANET_SLOTTYPE_ANY) && lhs.index == rhs.index && lhs.envindex == rhs.envindex) { if (lhs.flags & (JANET_SLOT_REF | JANET_SLOT_CONSTANT)) { return janet_equals(lhs.constant, rhs.constant); } else { return 1; } } return 0; } /* Move values from one slot to another. The destination must * be writeable (not a literal). */ void janetc_copy( JanetCompiler *c, JanetSlot dest, JanetSlot src) { if (dest.flags & JANET_SLOT_CONSTANT) { janetc_cerror(c, "cannot write to constant"); return; } if (janetc_sequal(dest, src)) return; /* If dest is a near register */ if (dest.envindex < 0 && dest.index >= 0 && dest.index <= 0xFF) { janetc_movenear(c, dest.index, src); return; } /* If src is a near register */ if (src.envindex < 0 && src.index >= 0 && src.index <= 0xFF) { janetc_moveback(c, dest, src.index); return; } /* Process: src -> near -> dest */ int32_t nearreg = janetc_allocnear(c, JANETC_REGTEMP_3); janetc_movenear(c, nearreg, src); janetc_moveback(c, dest, nearreg); /* Cleanup */ janetc_regalloc_freetemp(&c->scope->ra, nearreg, JANETC_REGTEMP_3); } /* Instruction templated emitters */ static int32_t emit1s(JanetCompiler *c, uint8_t op, JanetSlot s, int32_t rest, int wr) { int32_t reg = janetc_regnear(c, s, JANETC_REGTEMP_0); int32_t label = janet_v_count(c->buffer); janetc_emit(c, op | (reg << 8) | ((uint32_t)rest << 16)); if (wr) janetc_moveback(c, s, reg); janetc_free_regnear(c, s, reg, JANETC_REGTEMP_0); return label; } int32_t janetc_emit_s(JanetCompiler *c, uint8_t op, JanetSlot s, int wr) { int32_t reg = janetc_regfar(c, s, JANETC_REGTEMP_0); int32_t label = janet_v_count(c->buffer); janetc_emit(c, op | (reg << 8)); if (wr) janetc_moveback(c, s, reg); janetc_free_regnear(c, s, reg, JANETC_REGTEMP_0); return label; } int32_t janetc_emit_sl(JanetCompiler *c, uint8_t op, JanetSlot s, int32_t label) { int32_t current = janet_v_count(c->buffer) - 1; int32_t jump = label - current; if (jump < INT16_MIN || jump > INT16_MAX) { janetc_cerror(c, "jump is too far"); } return emit1s(c, op, s, jump, 0); } int32_t janetc_emit_st(JanetCompiler *c, uint8_t op, JanetSlot s, int32_t tflags) { return emit1s(c, op, s, tflags, 0); } int32_t janetc_emit_si(JanetCompiler *c, uint8_t op, JanetSlot s, int16_t immediate, int wr) { return emit1s(c, op, s, immediate, wr); } int32_t janetc_emit_su(JanetCompiler *c, uint8_t op, JanetSlot s, uint16_t immediate, int wr) { return emit1s(c, op, s, (int32_t) immediate, wr); } static int32_t emit2s(JanetCompiler *c, uint8_t op, JanetSlot s1, JanetSlot s2, int32_t rest, int wr) { int32_t reg1 = janetc_regnear(c, s1, JANETC_REGTEMP_0); int32_t reg2 = janetc_regnear(c, s2, JANETC_REGTEMP_1); int32_t label = janet_v_count(c->buffer); janetc_emit(c, op | (reg1 << 8) | (reg2 << 16) | ((uint32_t)rest << 24)); janetc_free_regnear(c, s2, reg2, JANETC_REGTEMP_1); if (wr) janetc_moveback(c, s1, reg1); janetc_free_regnear(c, s1, reg1, JANETC_REGTEMP_0); return label; } int32_t janetc_emit_ss(JanetCompiler *c, uint8_t op, JanetSlot s1, JanetSlot s2, int wr) { int32_t reg1 = janetc_regnear(c, s1, JANETC_REGTEMP_0); int32_t reg2 = janetc_regfar(c, s2, JANETC_REGTEMP_1); int32_t label = janet_v_count(c->buffer); janetc_emit(c, op | (reg1 << 8) | (reg2 << 16)); janetc_free_regnear(c, s2, reg2, JANETC_REGTEMP_1); if (wr) janetc_moveback(c, s1, reg1); janetc_free_regnear(c, s1, reg1, JANETC_REGTEMP_0); return label; } int32_t janetc_emit_ssi(JanetCompiler *c, uint8_t op, JanetSlot s1, JanetSlot s2, int8_t immediate, int wr) { return emit2s(c, op, s1, s2, immediate, wr); } int32_t janetc_emit_ssu(JanetCompiler *c, uint8_t op, JanetSlot s1, JanetSlot s2, uint8_t immediate, int wr) { return emit2s(c, op, s1, s2, (int32_t) immediate, wr); } int32_t janetc_emit_sss(JanetCompiler *c, uint8_t op, JanetSlot s1, JanetSlot s2, JanetSlot s3, int wr) { int32_t reg1 = janetc_regnear(c, s1, JANETC_REGTEMP_0); int32_t reg2 = janetc_regnear(c, s2, JANETC_REGTEMP_1); int32_t reg3 = janetc_regnear(c, s3, JANETC_REGTEMP_2); int32_t label = janet_v_count(c->buffer); janetc_emit(c, op | (reg1 << 8) | (reg2 << 16) | ((uint32_t)reg3 << 24)); janetc_free_regnear(c, s2, reg2, JANETC_REGTEMP_1); janetc_free_regnear(c, s3, reg3, JANETC_REGTEMP_2); if (wr) janetc_moveback(c, s1, reg1); janetc_free_regnear(c, s1, reg1, JANETC_REGTEMP_0); return label; } janet-1.41.2/src/core/emit.h000066400000000000000000000045741514534607600155530ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_EMIT_H #define JANET_EMIT_H #ifndef JANET_AMALG #include "compile.h" #endif void janetc_emit(JanetCompiler *c, uint32_t instr); int32_t janetc_allocfar(JanetCompiler *c); int32_t janetc_allocnear(JanetCompiler *c, JanetcRegisterTemp); int32_t janetc_emit_s(JanetCompiler *c, uint8_t op, JanetSlot s, int wr); int32_t janetc_emit_sl(JanetCompiler *c, uint8_t op, JanetSlot s, int32_t label); int32_t janetc_emit_st(JanetCompiler *c, uint8_t op, JanetSlot s, int32_t tflags); int32_t janetc_emit_si(JanetCompiler *c, uint8_t op, JanetSlot s, int16_t immediate, int wr); int32_t janetc_emit_su(JanetCompiler *c, uint8_t op, JanetSlot s, uint16_t immediate, int wr); int32_t janetc_emit_ss(JanetCompiler *c, uint8_t op, JanetSlot s1, JanetSlot s2, int wr); int32_t janetc_emit_ssi(JanetCompiler *c, uint8_t op, JanetSlot s1, JanetSlot s2, int8_t immediate, int wr); int32_t janetc_emit_ssu(JanetCompiler *c, uint8_t op, JanetSlot s1, JanetSlot s2, uint8_t immediate, int wr); int32_t janetc_emit_sss(JanetCompiler *c, uint8_t op, JanetSlot s1, JanetSlot s2, JanetSlot s3, int wr); /* Check if two slots are equivalent */ int janetc_sequal(JanetSlot x, JanetSlot y); /* Move value from one slot to another. Cannot copy to constant slots. */ void janetc_copy(JanetCompiler *c, JanetSlot dest, JanetSlot src); #endif janet-1.41.2/src/core/ev.c000066400000000000000000003744621514534607600152300ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "util.h" #include "gc.h" #include "state.h" #include "fiber.h" #endif #ifdef JANET_EV #include #include #ifdef JANET_WINDOWS #include #include #include #else #include #include #include #include #include #include #include #include #include #include #include #include #ifdef JANET_EV_EPOLL #include #include #endif #ifdef JANET_EV_KQUEUE #include #endif #ifdef JANET_EV_POLL #include #endif #endif typedef struct { JanetVM *thread; JanetFiber *fiber; uint32_t sched_id; enum { JANET_CP_MODE_READ, JANET_CP_MODE_WRITE, JANET_CP_MODE_CHOICE_READ, JANET_CP_MODE_CHOICE_WRITE, JANET_CP_MODE_CLOSE } mode; } JanetChannelPending; struct JanetChannel { JanetQueue items; JanetQueue read_pending; JanetQueue write_pending; int32_t limit; int closed; int is_threaded; #ifdef JANET_WINDOWS CRITICAL_SECTION lock; #else pthread_mutex_t lock; #endif }; typedef struct { JanetFiber *fiber; Janet value; JanetSignal sig; uint32_t expected_sched_id; /* If the fiber has been rescheduled this loop, don't run first scheduling. */ } JanetTask; /* Wrap return value by pairing it with the callback used to handle it * in the main thread */ typedef struct { JanetEVGenericMessage msg; JanetThreadedCallback cb; } JanetSelfPipeEvent; /* Structure used to initialize threads in the thread pool * (same head structure as self pipe event)*/ typedef struct { JanetEVGenericMessage msg; JanetThreadedCallback cb; JanetThreadedSubroutine subr; JanetHandle write_pipe; } JanetEVThreadInit; /* Structure used to initialize threads that run timeouts */ typedef struct { double sec; JanetVM *vm; JanetFiber *fiber; #ifdef JANET_WINDOWS HANDLE cancel_event; #endif } JanetThreadedTimeout; #define JANET_MAX_Q_CAPACITY 0x7FFFFFF static void janet_q_init(JanetQueue *q) { q->data = NULL; q->head = 0; q->tail = 0; q->capacity = 0; } static void janet_q_deinit(JanetQueue *q) { janet_free(q->data); } static int32_t janet_q_count(JanetQueue *q) { return (q->head > q->tail) ? (q->tail + q->capacity - q->head) : (q->tail - q->head); } static int janet_q_maybe_resize(JanetQueue *q, size_t itemsize) { int32_t count = janet_q_count(q); /* Resize if needed */ if (count + 1 >= q->capacity) { if (count + 1 >= JANET_MAX_Q_CAPACITY) return 1; int32_t newcap = (count + 2) * 2; if (newcap > JANET_MAX_Q_CAPACITY) newcap = JANET_MAX_Q_CAPACITY; q->data = janet_realloc(q->data, itemsize * newcap); if (NULL == q->data) { JANET_OUT_OF_MEMORY; } if (q->head > q->tail) { /* Two segments, fix 2nd seg. */ int32_t newhead = q->head + (newcap - q->capacity); size_t seg1 = (size_t)(q->capacity - q->head); if (seg1 > 0) { memmove((char *) q->data + (newhead * itemsize), (char *) q->data + (q->head * itemsize), seg1 * itemsize); } q->head = newhead; } q->capacity = newcap; } return 0; } static int janet_q_push(JanetQueue *q, void *item, size_t itemsize) { if (janet_q_maybe_resize(q, itemsize)) return 1; memcpy((char *) q->data + itemsize * q->tail, item, itemsize); q->tail = q->tail + 1 < q->capacity ? q->tail + 1 : 0; return 0; } static int janet_q_push_head(JanetQueue *q, void *item, size_t itemsize) { if (janet_q_maybe_resize(q, itemsize)) return 1; int32_t newhead = q->head - 1; if (newhead < 0) { newhead += q->capacity; } memcpy((char *) q->data + itemsize * newhead, item, itemsize); q->head = newhead; return 0; } static int janet_q_pop(JanetQueue *q, void *out, size_t itemsize) { if (q->head == q->tail) return 1; memcpy(out, (char *) q->data + itemsize * q->head, itemsize); q->head = q->head + 1 < q->capacity ? q->head + 1 : 0; return 0; } /* Get current timestamp (millisecond precision) */ static JanetTimestamp ts_now(void); /* Get current timestamp + an interval (millisecond precision) */ static JanetTimestamp ts_delta(JanetTimestamp ts, double delta) { if (isinf(delta)) { return delta < 0 ? ts : INT64_MAX; } ts += (int64_t)round(delta * 1000); return ts; } /* Look at the next timeout value without removing it. */ static int peek_timeout(JanetTimeout *out) { if (janet_vm.tq_count == 0) return 0; *out = janet_vm.tq[0]; return 1; } /* Remove the next timeout from the priority queue */ static void pop_timeout(size_t index) { if (janet_vm.tq_count <= index) return; janet_vm.tq[index] = janet_vm.tq[--janet_vm.tq_count]; for (;;) { size_t left = (index << 1) + 1; size_t right = left + 1; size_t smallest = index; if (left < janet_vm.tq_count && (janet_vm.tq[left].when < janet_vm.tq[smallest].when)) smallest = left; if (right < janet_vm.tq_count && (janet_vm.tq[right].when < janet_vm.tq[smallest].when)) smallest = right; if (smallest == index) return; JanetTimeout temp = janet_vm.tq[index]; janet_vm.tq[index] = janet_vm.tq[smallest]; janet_vm.tq[smallest] = temp; index = smallest; } } /* Add a timeout to the timeout min heap */ static void add_timeout(JanetTimeout to) { size_t oldcount = janet_vm.tq_count; size_t newcount = oldcount + 1; if (newcount > janet_vm.tq_capacity) { size_t newcap = 2 * newcount; JanetTimeout *tq = janet_realloc(janet_vm.tq, newcap * sizeof(JanetTimeout)); if (NULL == tq) { JANET_OUT_OF_MEMORY; } janet_vm.tq = tq; janet_vm.tq_capacity = newcap; } /* Append */ janet_vm.tq_count = (int32_t) newcount; janet_vm.tq[oldcount] = to; /* Heapify */ size_t index = oldcount; while (index > 0) { size_t parent = (index - 1) >> 1; if (janet_vm.tq[parent].when <= janet_vm.tq[index].when) break; /* Swap */ JanetTimeout tmp = janet_vm.tq[index]; janet_vm.tq[index] = janet_vm.tq[parent]; janet_vm.tq[parent] = tmp; /* Next */ index = parent; } } void janet_async_end(JanetFiber *fiber) { if (fiber->ev_callback) { if (fiber->ev_stream->read_fiber == fiber) { fiber->ev_stream->read_fiber = NULL; } if (fiber->ev_stream->write_fiber == fiber) { fiber->ev_stream->write_fiber = NULL; } fiber->ev_callback(fiber, JANET_ASYNC_EVENT_DEINIT); janet_gcunroot(janet_wrap_abstract(fiber->ev_stream)); fiber->ev_callback = NULL; if (!(fiber->flags & JANET_FIBER_EV_FLAG_IN_FLIGHT)) { if (fiber->ev_state) { janet_free(fiber->ev_state); fiber->ev_state = NULL; } janet_ev_dec_refcount(); } } } void janet_async_in_flight(JanetFiber *fiber) { #ifdef JANET_WINDOWS fiber->flags |= JANET_FIBER_EV_FLAG_IN_FLIGHT; #else (void) fiber; #endif } void janet_async_start_fiber(JanetFiber *fiber, JanetStream *stream, JanetAsyncMode mode, JanetEVCallback callback, void *state) { janet_assert(!fiber->ev_callback, "double async on fiber"); if (mode & JANET_ASYNC_LISTEN_READ) { stream->read_fiber = fiber; } if (mode & JANET_ASYNC_LISTEN_WRITE) { stream->write_fiber = fiber; } fiber->ev_callback = callback; fiber->ev_stream = stream; janet_ev_inc_refcount(); janet_gcroot(janet_wrap_abstract(stream)); fiber->ev_state = state; callback(fiber, JANET_ASYNC_EVENT_INIT); } void janet_async_start(JanetStream *stream, JanetAsyncMode mode, JanetEVCallback callback, void *state) { janet_async_start_fiber(janet_vm.root_fiber, stream, mode, callback, state); janet_await(); } void janet_fiber_did_resume(JanetFiber *fiber) { janet_async_end(fiber); } static void janet_stream_checktoclose(JanetStream *stream) { if ((stream->flags & JANET_STREAM_TOCLOSE) && !stream->read_fiber && !stream->write_fiber) { janet_stream_close(stream); } } /* Forward declaration */ static void janet_register_stream(JanetStream *stream); static const JanetMethod ev_default_stream_methods[] = { {"close", janet_cfun_stream_close}, {"read", janet_cfun_stream_read}, {"chunk", janet_cfun_stream_chunk}, {"write", janet_cfun_stream_write}, {NULL, NULL} }; /* Create a stream*/ JanetStream *janet_stream_ext(JanetHandle handle, uint32_t flags, const JanetMethod *methods, size_t size) { janet_assert(size >= sizeof(JanetStream), "bad size"); JanetStream *stream = janet_abstract(&janet_stream_type, size); stream->handle = handle; stream->flags = flags; stream->read_fiber = NULL; stream->write_fiber = NULL; if (methods == NULL) methods = ev_default_stream_methods; stream->methods = methods; stream->index = 0; janet_register_stream(stream); return stream; } JanetStream *janet_stream(JanetHandle handle, uint32_t flags, const JanetMethod *methods) { return janet_stream_ext(handle, flags, methods, sizeof(JanetStream)); } static void janet_stream_close_impl(JanetStream *stream) { stream->flags |= JANET_STREAM_CLOSED; int canclose = !(stream->flags & JANET_STREAM_NOT_CLOSEABLE); #ifdef JANET_WINDOWS if (stream->handle != INVALID_HANDLE_VALUE) { #ifdef JANET_NET if (stream->flags & JANET_STREAM_SOCKET) { if (canclose) closesocket((SOCKET) stream->handle); } else #endif { if (canclose) CloseHandle(stream->handle); } stream->handle = INVALID_HANDLE_VALUE; } #else if (stream->handle != -1) { if (canclose) close(stream->handle); stream->handle = -1; #ifdef JANET_EV_POLL uint32_t i = stream->index; size_t j = janet_vm.stream_count - 1; JanetStream *last = janet_vm.streams[j]; struct pollfd lastfd = janet_vm.fds[j + 1]; janet_vm.fds[i + 1] = lastfd; janet_vm.streams[i] = last; last->index = stream->index; janet_vm.stream_count--; #endif } #endif } void janet_stream_close(JanetStream *stream) { JanetFiber *rf = stream->read_fiber; JanetFiber *wf = stream->write_fiber; if (rf && rf->ev_callback) { rf->ev_callback(rf, JANET_ASYNC_EVENT_CLOSE); stream->read_fiber = NULL; } if (wf && wf->ev_callback) { wf->ev_callback(wf, JANET_ASYNC_EVENT_CLOSE); stream->write_fiber = NULL; } janet_stream_close_impl(stream); } /* Called to clean up a stream */ static int janet_stream_gc(void *p, size_t s) { (void) s; JanetStream *stream = (JanetStream *)p; janet_stream_close_impl(stream); return 0; } /* Mark a stream for GC */ static int janet_stream_mark(void *p, size_t s) { (void) s; JanetStream *stream = (JanetStream *) p; JanetFiber *rf = stream->read_fiber; JanetFiber *wf = stream->write_fiber; if (rf) { janet_mark(janet_wrap_fiber(rf)); } if (wf) { janet_mark(janet_wrap_fiber(wf)); } return 0; } static int janet_stream_getter(void *p, Janet key, Janet *out) { JanetStream *stream = (JanetStream *)p; if (!janet_checktype(key, JANET_KEYWORD)) return 0; const JanetMethod *stream_methods = stream->methods; return janet_getmethod(janet_unwrap_keyword(key), stream_methods, out); } static void janet_stream_marshal(void *p, JanetMarshalContext *ctx) { JanetStream *s = p; if (!(ctx->flags & JANET_MARSHAL_UNSAFE)) { janet_panic("can only marshal stream with unsafe flag"); } janet_marshal_abstract(ctx, p); janet_marshal_int(ctx, (int32_t) s->flags); janet_marshal_ptr(ctx, s->methods); #ifdef JANET_WINDOWS /* TODO - ref counting to avoid situation where a handle is closed or GCed * while in transit, and it's value gets reused. DuplicateHandle does not work * for network sockets, and in general for winsock it is better to not duplicate * unless there is a need to. */ HANDLE duph = INVALID_HANDLE_VALUE; if (s->flags & JANET_STREAM_SOCKET) { duph = s->handle; } else { DuplicateHandle( GetCurrentProcess(), s->handle, GetCurrentProcess(), &duph, 0, FALSE, DUPLICATE_SAME_ACCESS); } janet_marshal_int64(ctx, (int64_t)(duph)); #else /* Marshal after dup because it is easier than maintaining our own ref counting. */ int duph = dup(s->handle); if (duph < 0) janet_panicf("failed to duplicate stream handle: %V", janet_ev_lasterr()); janet_marshal_int(ctx, (int32_t)(duph)); #endif } static void *janet_stream_unmarshal(JanetMarshalContext *ctx) { if (!(ctx->flags & JANET_MARSHAL_UNSAFE)) { janet_panic("can only unmarshal stream with unsafe flag"); } JanetStream *p = janet_unmarshal_abstract(ctx, sizeof(JanetStream)); /* Can't share listening state and such across threads */ p->read_fiber = NULL; p->write_fiber = NULL; p->flags = (uint32_t) janet_unmarshal_int(ctx); p->methods = janet_unmarshal_ptr(ctx); #ifdef JANET_WINDOWS p->handle = (JanetHandle) janet_unmarshal_int64(ctx); #else p->handle = (JanetHandle) janet_unmarshal_int(ctx); #endif #ifdef JANET_EV_POLL janet_register_stream(p); #endif return p; } static Janet janet_stream_next(void *p, Janet key) { JanetStream *stream = (JanetStream *)p; return janet_nextmethod(stream->methods, key); } static void janet_stream_tostring(void *p, JanetBuffer *buffer) { JanetStream *stream = p; /* Let user print the file descriptor for debugging */ janet_formatb(buffer, "[fd=%d]", stream->handle); } const JanetAbstractType janet_stream_type = { "core/stream", janet_stream_gc, janet_stream_mark, janet_stream_getter, NULL, janet_stream_marshal, janet_stream_unmarshal, janet_stream_tostring, NULL, NULL, janet_stream_next, JANET_ATEND_NEXT }; /* Register a fiber to resume with value */ static void janet_schedule_general(JanetFiber *fiber, Janet value, JanetSignal sig, int soon) { if (fiber->gc.flags & JANET_FIBER_EV_FLAG_CANCELED) return; if (!(fiber->gc.flags & JANET_FIBER_FLAG_ROOT)) { Janet task_element = janet_wrap_fiber(fiber); janet_table_put(&janet_vm.active_tasks, task_element, janet_wrap_true()); } JanetTask t = { fiber, value, sig, ++fiber->sched_id }; fiber->gc.flags |= JANET_FIBER_FLAG_ROOT; if (sig == JANET_SIGNAL_ERROR) fiber->gc.flags |= JANET_FIBER_EV_FLAG_CANCELED; if (soon) { janet_q_push_head(&janet_vm.spawn, &t, sizeof(t)); } else { janet_q_push(&janet_vm.spawn, &t, sizeof(t)); } } void janet_schedule_signal(JanetFiber *fiber, Janet value, JanetSignal sig) { janet_schedule_general(fiber, value, sig, 0); } void janet_schedule_soon(JanetFiber *fiber, Janet value, JanetSignal sig) { janet_schedule_general(fiber, value, sig, 1); } void janet_cancel(JanetFiber *fiber, Janet value) { if (!(fiber->gc.flags & JANET_FIBER_FLAG_ROOT)) { janet_panic("cannot cancel non-task fiber"); } janet_schedule_signal(fiber, value, JANET_SIGNAL_ERROR); } void janet_schedule(JanetFiber *fiber, Janet value) { janet_schedule_signal(fiber, value, JANET_SIGNAL_OK); } /* Mark all pending tasks */ void janet_ev_mark(void) { /* Pending tasks */ JanetTask *tasks = janet_vm.spawn.data; if (janet_vm.spawn.head <= janet_vm.spawn.tail) { for (int32_t i = janet_vm.spawn.head; i < janet_vm.spawn.tail; i++) { janet_mark(janet_wrap_fiber(tasks[i].fiber)); janet_mark(tasks[i].value); } } else { for (int32_t i = janet_vm.spawn.head; i < janet_vm.spawn.capacity; i++) { janet_mark(janet_wrap_fiber(tasks[i].fiber)); janet_mark(tasks[i].value); } for (int32_t i = 0; i < janet_vm.spawn.tail; i++) { janet_mark(janet_wrap_fiber(tasks[i].fiber)); janet_mark(tasks[i].value); } } /* Pending timeouts */ for (size_t i = 0; i < janet_vm.tq_count; i++) { janet_mark(janet_wrap_fiber(janet_vm.tq[i].fiber)); if (janet_vm.tq[i].curr_fiber != NULL) { janet_mark(janet_wrap_fiber(janet_vm.tq[i].curr_fiber)); } } } static int janet_channel_push(JanetChannel *channel, Janet x, int mode); static int janet_channel_pop(JanetChannel *channel, Janet *item, int is_choice); static Janet make_supervisor_event(const char *name, JanetFiber *fiber, int threaded) { Janet tup[3]; tup[0] = janet_ckeywordv(name); tup[1] = threaded ? fiber->last_value : janet_wrap_fiber(fiber) ; if (fiber->env != NULL) { tup[2] = janet_table_get(fiber->env, janet_ckeywordv("task-id")); } else { tup[2] = janet_wrap_nil(); } return janet_wrap_tuple(janet_tuple_n(tup, 3)); } /* Common init code */ void janet_ev_init_common(void) { janet_q_init(&janet_vm.spawn); janet_vm.tq = NULL; janet_vm.tq_count = 0; janet_vm.tq_capacity = 0; janet_table_init_raw(&janet_vm.threaded_abstracts, 0); janet_table_init_raw(&janet_vm.active_tasks, 0); janet_table_init_raw(&janet_vm.signal_handlers, 0); janet_rng_seed(&janet_vm.ev_rng, 0); #ifndef JANET_WINDOWS pthread_attr_init(&janet_vm.new_thread_attr); pthread_attr_setdetachstate(&janet_vm.new_thread_attr, PTHREAD_CREATE_DETACHED); #endif } #if JANET_ANDROID static void janet_timeout_stop(int sig_num) { if (sig_num == SIGUSR1) { pthread_exit(0); } } #endif static void handle_timeout_worker(JanetTimeout to, int cancel) { if (!to.has_worker) return; #ifdef JANET_WINDOWS if (cancel && to.worker_event) { SetEvent(to.worker_event); } WaitForSingleObject(to.worker, INFINITE); CloseHandle(to.worker); if (to.worker_event) { CloseHandle(to.worker_event); } #else #ifdef JANET_ANDROID if (cancel) janet_assert(!pthread_kill(to.worker, SIGUSR1), "pthread_kill"); #else if (cancel) janet_assert(!pthread_cancel(to.worker), "pthread_cancel"); #endif void *res = NULL; janet_assert(!pthread_join(to.worker, &res), "pthread_join"); #endif } /* Common deinit code */ void janet_ev_deinit_common(void) { JanetTimeout to; while (peek_timeout(&to)) { handle_timeout_worker(to, 1); pop_timeout(0); } janet_q_deinit(&janet_vm.spawn); janet_free(janet_vm.tq); janet_table_deinit(&janet_vm.threaded_abstracts); janet_table_deinit(&janet_vm.active_tasks); janet_table_deinit(&janet_vm.signal_handlers); #ifndef JANET_WINDOWS pthread_attr_destroy(&janet_vm.new_thread_attr); #endif } /* Shorthand to yield to event loop */ void janet_await(void) { /* Store the fiber in a global table */ janet_signalv(JANET_SIGNAL_EVENT, janet_wrap_nil()); } /* Set timeout for the current root fiber */ void janet_addtimeout(double sec) { JanetFiber *fiber = janet_vm.root_fiber; JanetTimeout to; to.when = ts_delta(ts_now(), sec); to.fiber = fiber; to.curr_fiber = NULL; to.sched_id = fiber->sched_id; to.is_error = 1; to.has_worker = 0; add_timeout(to); } /* Set timeout for the current root fiber but resume with nil instead of raising an error */ void janet_addtimeout_nil(double sec) { JanetFiber *fiber = janet_vm.root_fiber; JanetTimeout to; to.when = ts_delta(ts_now(), sec); to.fiber = fiber; to.curr_fiber = NULL; to.sched_id = fiber->sched_id; to.is_error = 0; to.has_worker = 0; add_timeout(to); } static void janet_timeout_cb(JanetEVGenericMessage msg) { (void) msg; janet_interpreter_interrupt_handled(&janet_vm); } #ifdef JANET_WINDOWS static DWORD WINAPI janet_timeout_body(LPVOID ptr) { JanetThreadedTimeout tto = *(JanetThreadedTimeout *)ptr; janet_free(ptr); JanetTimestamp wait_begin = ts_now(); DWORD duration = (DWORD)round(tto.sec * 1000); DWORD res = WAIT_TIMEOUT; JanetTimestamp wait_end = ts_now(); for (DWORD i = 1; res == WAIT_TIMEOUT && (wait_end - wait_begin) < duration; i++) { res = WaitForSingleObject(tto.cancel_event, (duration + i)); wait_end = ts_now(); } /* only send interrupt message if result is WAIT_TIMEOUT */ if (res == WAIT_TIMEOUT) { janet_interpreter_interrupt(tto.vm); JanetEVGenericMessage msg = {0}; janet_ev_post_event(tto.vm, janet_timeout_cb, msg); } return 0; } #else static void *janet_timeout_body(void *ptr) { #ifdef JANET_ANDROID struct sigaction action; memset(&action, 0, sizeof(action)); sigemptyset(&action.sa_mask); action.sa_flags = 0; action.sa_handler = &janet_timeout_stop; sigaction(SIGUSR1, &action, NULL); #endif JanetThreadedTimeout tto = *(JanetThreadedTimeout *)ptr; janet_free(ptr); struct timespec ts; ts.tv_sec = (time_t) tto.sec; ts.tv_nsec = (tto.sec <= UINT32_MAX) ? (long)((tto.sec - ((uint32_t)tto.sec)) * 1000000000) : 0; nanosleep(&ts, &ts); janet_interpreter_interrupt(tto.vm); JanetEVGenericMessage msg = {0}; janet_ev_post_event(tto.vm, janet_timeout_cb, msg); return NULL; } #endif void janet_ev_inc_refcount(void) { janet_atomic_inc(&janet_vm.listener_count); } void janet_ev_dec_refcount(void) { janet_atomic_dec(&janet_vm.listener_count); } /* Channels */ #define JANET_MAX_CHANNEL_CAPACITY 0xFFFFFF static inline int janet_chan_is_threaded(JanetChannel *chan) { return chan->is_threaded; } static int janet_chan_pack(JanetChannel *chan, Janet *x) { if (!janet_chan_is_threaded(chan)) return 0; switch (janet_type(*x)) { default: { JanetBuffer *buf = janet_malloc(sizeof(JanetBuffer)); if (NULL == buf) { JANET_OUT_OF_MEMORY; } janet_buffer_init(buf, 10); janet_marshal(buf, *x, NULL, JANET_MARSHAL_UNSAFE); *x = janet_wrap_buffer(buf); return 0; } case JANET_NIL: case JANET_NUMBER: case JANET_POINTER: case JANET_BOOLEAN: case JANET_CFUNCTION: return 0; } } static int janet_chan_unpack(JanetChannel *chan, Janet *x, int is_cleanup) { if (!janet_chan_is_threaded(chan)) return 0; switch (janet_type(*x)) { default: return 1; case JANET_BUFFER: { JanetBuffer *buf = janet_unwrap_buffer(*x); int flags = is_cleanup ? (JANET_MARSHAL_UNSAFE | JANET_MARSHAL_DECREF) : JANET_MARSHAL_UNSAFE; *x = janet_unmarshal(buf->data, buf->count, flags, NULL, NULL); janet_buffer_deinit(buf); janet_free(buf); return 0; } case JANET_NIL: case JANET_NUMBER: case JANET_POINTER: case JANET_BOOLEAN: case JANET_CFUNCTION: return 0; } } static void janet_chan_init(JanetChannel *chan, int32_t limit, int threaded) { chan->limit = limit; chan->closed = 0; chan->is_threaded = threaded; janet_q_init(&chan->items); janet_q_init(&chan->read_pending); janet_q_init(&chan->write_pending); janet_os_mutex_init((JanetOSMutex *) &chan->lock); } static void janet_chan_lock(JanetChannel *chan) { if (!janet_chan_is_threaded(chan)) return; janet_os_mutex_lock((JanetOSMutex *) &chan->lock); } static void janet_chan_unlock(JanetChannel *chan) { if (!janet_chan_is_threaded(chan)) return; janet_os_mutex_unlock((JanetOSMutex *) &chan->lock); } static void janet_chan_deinit(JanetChannel *chan) { if (janet_chan_is_threaded(chan)) { Janet item; janet_chan_lock(chan); janet_q_deinit(&chan->read_pending); janet_q_deinit(&chan->write_pending); while (!janet_q_pop(&chan->items, &item, sizeof(item))) { janet_chan_unpack(chan, &item, 1); } janet_q_deinit(&chan->items); janet_chan_unlock(chan); } else { janet_q_deinit(&chan->read_pending); janet_q_deinit(&chan->write_pending); janet_q_deinit(&chan->items); } janet_os_mutex_deinit((JanetOSMutex *) &chan->lock); } /* * Janet Channel abstract type */ static Janet janet_wrap_channel(JanetChannel *channel) { return janet_wrap_abstract(channel); } static int janet_chanat_gc(void *p, size_t s) { (void) s; JanetChannel *channel = p; janet_chan_deinit(channel); return 0; } static void janet_chanat_remove_vmref(JanetQueue *fq) { JanetChannelPending *pending = fq->data; if (fq->head <= fq->tail) { for (int32_t i = fq->head; i < fq->tail; i++) { if (pending[i].thread == &janet_vm) pending[i].thread = NULL; } } else { for (int32_t i = fq->head; i < fq->capacity; i++) { if (pending[i].thread == &janet_vm) pending[i].thread = NULL; } for (int32_t i = 0; i < fq->tail; i++) { if (pending[i].thread == &janet_vm) pending[i].thread = NULL; } } } static int janet_chanat_gcperthread(void *p, size_t s) { (void) s; JanetChannel *chan = p; janet_chan_lock(chan); /* Make sure that the internals of the threaded channel no longer reference _this_ thread. Replace * those references with NULL. */ janet_chanat_remove_vmref(&chan->read_pending); janet_chanat_remove_vmref(&chan->write_pending); janet_chan_unlock(chan); return 0; } static void janet_chanat_mark_fq(JanetQueue *fq) { JanetChannelPending *pending = fq->data; if (fq->head <= fq->tail) { for (int32_t i = fq->head; i < fq->tail; i++) janet_mark(janet_wrap_fiber(pending[i].fiber)); } else { for (int32_t i = fq->head; i < fq->capacity; i++) janet_mark(janet_wrap_fiber(pending[i].fiber)); for (int32_t i = 0; i < fq->tail; i++) janet_mark(janet_wrap_fiber(pending[i].fiber)); } } static int janet_chanat_mark(void *p, size_t s) { (void) s; JanetChannel *chan = p; janet_chanat_mark_fq(&chan->read_pending); janet_chanat_mark_fq(&chan->write_pending); JanetQueue *items = &chan->items; Janet *data = chan->items.data; if (items->head <= items->tail) { for (int32_t i = items->head; i < items->tail; i++) janet_mark(data[i]); } else { for (int32_t i = items->head; i < items->capacity; i++) janet_mark(data[i]); for (int32_t i = 0; i < items->tail; i++) janet_mark(data[i]); } return 0; } static Janet make_write_result(JanetChannel *channel) { Janet *tup = janet_tuple_begin(2); tup[0] = janet_ckeywordv("give"); tup[1] = janet_wrap_channel(channel); return janet_wrap_tuple(janet_tuple_end(tup)); } static Janet make_read_result(JanetChannel *channel, Janet x) { Janet *tup = janet_tuple_begin(3); tup[0] = janet_ckeywordv("take"); tup[1] = janet_wrap_channel(channel); tup[2] = x; return janet_wrap_tuple(janet_tuple_end(tup)); } static Janet make_close_result(JanetChannel *channel) { Janet *tup = janet_tuple_begin(2); tup[0] = janet_ckeywordv("close"); tup[1] = janet_wrap_channel(channel); return janet_wrap_tuple(janet_tuple_end(tup)); } /* Callback to use for scheduling a fiber from another thread. */ static void janet_thread_chan_cb(JanetEVGenericMessage msg) { uint32_t sched_id = (uint32_t) msg.argi; JanetFiber *fiber = msg.fiber; int mode = msg.tag; JanetChannel *channel = (JanetChannel *) msg.argp; Janet x = msg.argj; janet_chan_lock(channel); if (fiber->sched_id == sched_id) { if (mode == JANET_CP_MODE_CHOICE_READ) { janet_assert(!janet_chan_unpack(channel, &x, 0), "packing error"); janet_schedule(fiber, make_read_result(channel, x)); } else if (mode == JANET_CP_MODE_CHOICE_WRITE) { janet_schedule(fiber, make_write_result(channel)); } else if (mode == JANET_CP_MODE_READ) { janet_assert(!janet_chan_unpack(channel, &x, 0), "packing error"); janet_schedule(fiber, x); } else if (mode == JANET_CP_MODE_WRITE) { janet_schedule(fiber, janet_wrap_channel(channel)); } else { /* (mode == JANET_CP_MODE_CLOSE) */ janet_schedule(fiber, janet_wrap_nil()); } } else if (mode != JANET_CP_MODE_CLOSE) { /* Fiber has already been cancelled or resumed. */ /* Resend event to another waiting thread, depending on mode */ int is_read = (mode == JANET_CP_MODE_CHOICE_READ) || (mode == JANET_CP_MODE_READ); if (is_read) { JanetChannelPending reader; while (!janet_q_pop(&channel->read_pending, &reader, sizeof(reader))) { JanetVM *vm = reader.thread; if (!vm) continue; JanetEVGenericMessage msg; msg.tag = reader.mode; msg.fiber = reader.fiber; msg.argi = (int32_t) reader.sched_id; msg.argp = channel; msg.argj = x; janet_ev_post_event(vm, janet_thread_chan_cb, msg); break; } } else { JanetChannelPending writer; while (!janet_q_pop(&channel->write_pending, &writer, sizeof(writer))) { JanetVM *vm = writer.thread; if (!vm) continue; JanetEVGenericMessage msg; msg.tag = writer.mode; msg.fiber = writer.fiber; msg.argi = (int32_t) writer.sched_id; msg.argp = channel; msg.argj = janet_wrap_nil(); janet_ev_post_event(vm, janet_thread_chan_cb, msg); break; } } } janet_chan_unlock(channel); } /* Push a value to a channel, and return 1 if channel should block, zero otherwise. * If the push would block, will add to the write_pending queue in the channel. * Handles both threaded and unthreaded channels. */ static int janet_channel_push_with_lock(JanetChannel *channel, Janet x, int mode) { JanetChannelPending reader; int is_empty; if (janet_chan_pack(channel, &x)) { janet_chan_unlock(channel); janet_panicf("failed to pack value for channel: %v", x); } if (channel->closed) { janet_chan_unlock(channel); janet_panic("cannot write to closed channel"); } int is_threaded = janet_chan_is_threaded(channel); if (is_threaded) { /* don't dereference fiber from another thread */ is_empty = janet_q_pop(&channel->read_pending, &reader, sizeof(reader)); } else { do { is_empty = janet_q_pop(&channel->read_pending, &reader, sizeof(reader)); } while (!is_empty && (reader.sched_id != reader.fiber->sched_id)); } if (is_empty) { /* No pending reader */ if (janet_q_push(&channel->items, &x, sizeof(Janet))) { janet_chan_unlock(channel); janet_panicf("channel overflow: %v", x); } else if (janet_q_count(&channel->items) > channel->limit) { /* No root fiber, we are in completion on a root fiber. Don't block. */ if (mode == 2) { janet_chan_unlock(channel); return 1; } /* Pushed successfully, but should block. */ JanetChannelPending pending; pending.thread = &janet_vm; pending.fiber = janet_vm.root_fiber, pending.sched_id = janet_vm.root_fiber->sched_id, pending.mode = mode ? JANET_CP_MODE_CHOICE_WRITE : JANET_CP_MODE_WRITE; janet_q_push(&channel->write_pending, &pending, sizeof(pending)); janet_chan_unlock(channel); if (is_threaded) { janet_gcroot(janet_wrap_fiber(pending.fiber)); } return 1; } } else { /* Pending reader */ if (is_threaded) { JanetVM *vm = reader.thread; JanetEVGenericMessage msg; msg.tag = reader.mode; msg.fiber = reader.fiber; msg.argi = (int32_t) reader.sched_id; msg.argp = channel; msg.argj = x; if (vm) { janet_ev_post_event(vm, janet_thread_chan_cb, msg); } } else { if (reader.mode == JANET_CP_MODE_CHOICE_READ) { janet_schedule(reader.fiber, make_read_result(channel, x)); } else { janet_schedule(reader.fiber, x); } } } janet_chan_unlock(channel); return 0; } static int janet_channel_push(JanetChannel *channel, Janet x, int mode) { janet_chan_lock(channel); return janet_channel_push_with_lock(channel, x, mode); } /* Pop from a channel - returns 1 if item was obtained, 0 otherwise. The item * is returned by reference. If the pop would block, will add to the read_pending * queue in the channel. */ static int janet_channel_pop_with_lock(JanetChannel *channel, Janet *item, int is_choice) { JanetChannelPending writer; if (channel->closed) { janet_chan_unlock(channel); *item = janet_wrap_nil(); return 1; } int is_threaded = janet_chan_is_threaded(channel); if (janet_q_pop(&channel->items, item, sizeof(Janet))) { /* Queue empty */ if (is_choice == 2) return 0; /* Skip pending read */ JanetChannelPending pending; pending.thread = &janet_vm; pending.fiber = janet_vm.root_fiber, pending.sched_id = janet_vm.root_fiber->sched_id; pending.mode = is_choice ? JANET_CP_MODE_CHOICE_READ : JANET_CP_MODE_READ; janet_q_push(&channel->read_pending, &pending, sizeof(pending)); janet_chan_unlock(channel); if (is_threaded) { janet_gcroot(janet_wrap_fiber(pending.fiber)); } return 0; } janet_assert(!janet_chan_unpack(channel, item, 0), "bad channel packing"); if (!janet_q_pop(&channel->write_pending, &writer, sizeof(writer))) { /* Pending writer */ if (is_threaded) { JanetVM *vm = writer.thread; JanetEVGenericMessage msg; msg.tag = writer.mode; msg.fiber = writer.fiber; msg.argi = (int32_t) writer.sched_id; msg.argp = channel; msg.argj = janet_wrap_nil(); if (vm) { janet_ev_post_event(vm, janet_thread_chan_cb, msg); } } else { if (writer.mode == JANET_CP_MODE_CHOICE_WRITE) { janet_schedule(writer.fiber, make_write_result(channel)); } else { janet_schedule(writer.fiber, janet_wrap_abstract(channel)); } } } janet_chan_unlock(channel); return 1; } static int janet_channel_pop(JanetChannel *channel, Janet *item, int is_choice) { janet_chan_lock(channel); return janet_channel_pop_with_lock(channel, item, is_choice); } JanetChannel *janet_channel_unwrap(void *abstract) { return abstract; } JanetChannel *janet_getchannel(const Janet *argv, int32_t n) { return janet_channel_unwrap(janet_getabstract(argv, n, &janet_channel_type)); } JanetChannel *janet_optchannel(const Janet *argv, int32_t argc, int32_t n, JanetChannel *dflt) { if (argc > n && !janet_checktype(argv[n], JANET_NIL)) { return janet_getchannel(argv, n); } else { return dflt; } } int janet_channel_give(JanetChannel *channel, Janet x) { return janet_channel_push(channel, x, 2); } int janet_channel_take(JanetChannel *channel, Janet *out) { return janet_channel_pop(channel, out, 2); } JanetChannel *janet_channel_make(uint32_t limit) { janet_assert(limit <= INT32_MAX, "bad limit"); JanetChannel *channel = janet_abstract(&janet_channel_type, sizeof(JanetChannel)); janet_chan_init(channel, (int32_t) limit, 0); return channel; } JanetChannel *janet_channel_make_threaded(uint32_t limit) { janet_assert(limit <= INT32_MAX, "bad limit"); JanetChannel *channel = janet_abstract_threaded(&janet_channel_type, sizeof(JanetChannel)); janet_chan_init(channel, (int32_t) limit, 0); return channel; } /* Channel Methods */ JANET_CORE_FN(cfun_channel_push, "(ev/give channel value)", "Write a value to a channel, suspending the current fiber if the channel is full. " "Returns the channel if the write succeeded, nil otherwise.") { janet_fixarity(argc, 2); JanetChannel *channel = janet_getchannel(argv, 0); if (janet_vm.coerce_error) { janet_panic("cannot give to channel inside janet_call"); } if (janet_channel_push(channel, argv[1], 0)) { janet_await(); } return argv[0]; } JANET_CORE_FN(cfun_channel_pop, "(ev/take channel)", "Read from a channel, suspending the current fiber if no value is available.") { janet_fixarity(argc, 1); JanetChannel *channel = janet_getchannel(argv, 0); Janet item; if (janet_vm.coerce_error) { janet_panic("cannot take from channel inside janet_call"); } if (janet_channel_pop(channel, &item, 0)) { janet_schedule(janet_vm.root_fiber, item); } janet_await(); } static void chan_unlock_args(const Janet *argv, int32_t n) { for (int32_t i = 0; i < n; i++) { int32_t len; const Janet *data; JanetChannel *chan; if (janet_indexed_view(argv[i], &data, &len) && len == 2) { chan = janet_getchannel(data, 0); } else { chan = janet_getchannel(argv, i); } janet_chan_unlock(chan); } } JANET_CORE_FN(cfun_channel_choice, "(ev/select & clauses)", "Block until the first of several channel operations occur. Returns a " "tuple of the form [:give chan], [:take chan x], or [:close chan], " "where a :give tuple is the result of a write and a :take tuple is the " "result of a read. Each clause must be either a channel (for a channel " "take operation) or a tuple [channel x] (for a channel give operation). " "Operations are tried in order such that earlier clauses take " "precedence over later clauses. Both give and take operations can " "return a [:close chan] tuple, which indicates that the specified " "channel was closed while waiting, or that the channel was already " "closed.") { janet_arity(argc, 1, -1); int32_t len; const Janet *data; if (janet_vm.coerce_error) { janet_panic("cannot select from channel inside janet_call"); } /* Check channels for immediate reads and writes */ for (int32_t i = 0; i < argc; i++) { if (janet_indexed_view(argv[i], &data, &len) && len == 2) { /* Write */ JanetChannel *chan = janet_getchannel(data, 0); janet_chan_lock(chan); if (chan->closed) { janet_chan_unlock(chan); chan_unlock_args(argv, i); return make_close_result(chan); } if (janet_q_count(&chan->items) < chan->limit) { janet_channel_push_with_lock(chan, data[1], 1); chan_unlock_args(argv, i); return make_write_result(chan); } } else { /* Read */ JanetChannel *chan = janet_getchannel(argv, i); janet_chan_lock(chan); if (chan->closed) { janet_chan_unlock(chan); chan_unlock_args(argv, i); return make_close_result(chan); } if (chan->items.head != chan->items.tail) { Janet item; janet_channel_pop_with_lock(chan, &item, 1); chan_unlock_args(argv, i); return make_read_result(chan, item); } } } /* Wait for all readers or writers */ for (int32_t i = 0; i < argc; i++) { if (janet_indexed_view(argv[i], &data, &len) && len == 2) { /* Write */ JanetChannel *chan = janet_getchannel(data, 0); janet_chan_lock(chan); janet_channel_push_with_lock(chan, data[1], 1); } else { /* Read */ Janet item; JanetChannel *chan = janet_getchannel(argv, i); janet_chan_lock(chan); janet_channel_pop_with_lock(chan, &item, 1); } } janet_await(); } JANET_CORE_FN(cfun_channel_full, "(ev/full channel)", "Check if a channel is full or not.") { janet_fixarity(argc, 1); JanetChannel *channel = janet_getchannel(argv, 0); janet_chan_lock(channel); Janet ret = janet_wrap_boolean(janet_q_count(&channel->items) >= channel->limit); janet_chan_unlock(channel); return ret; } JANET_CORE_FN(cfun_channel_capacity, "(ev/capacity channel)", "Get the number of items a channel will store before blocking writers.") { janet_fixarity(argc, 1); JanetChannel *channel = janet_getchannel(argv, 0); janet_chan_lock(channel); Janet ret = janet_wrap_integer(channel->limit); janet_chan_unlock(channel); return ret; } JANET_CORE_FN(cfun_channel_count, "(ev/count channel)", "Get the number of items currently waiting in a channel.") { janet_fixarity(argc, 1); JanetChannel *channel = janet_getchannel(argv, 0); janet_chan_lock(channel); Janet ret = janet_wrap_integer(janet_q_count(&channel->items)); janet_chan_unlock(channel); return ret; } /* Fisher yates shuffle of arguments to get fairness */ static void fisher_yates_args(int32_t argc, Janet *argv) { for (int32_t i = argc; i > 1; i--) { int32_t swap_index = janet_rng_u32(&janet_vm.ev_rng) % i; Janet temp = argv[swap_index]; argv[swap_index] = argv[i - 1]; argv[i - 1] = temp; } } JANET_CORE_FN(cfun_channel_rchoice, "(ev/rselect & clauses)", "Similar to ev/select, but will try clauses in a random order for fairness.") { fisher_yates_args(argc, argv); return cfun_channel_choice(argc, argv); } JANET_CORE_FN(cfun_channel_new, "(ev/chan &opt capacity)", "Create a new channel. capacity is the number of values to queue before " "blocking writers, defaults to 0 if not provided. Returns a new channel.") { janet_arity(argc, 0, 1); int32_t limit = janet_optnat(argv, argc, 0, 0); JanetChannel *channel = janet_abstract(&janet_channel_type, sizeof(JanetChannel)); janet_chan_init(channel, limit, 0); return janet_wrap_abstract(channel); } JANET_CORE_FN(cfun_channel_new_threaded, "(ev/thread-chan &opt limit)", "Create a threaded channel. A threaded channel is a channel that can be shared between threads and " "used to communicate between any number of operating system threads.") { janet_arity(argc, 0, 1); int32_t limit = janet_optnat(argv, argc, 0, 0); JanetChannel *tchan = janet_abstract_threaded(&janet_channel_type, sizeof(JanetChannel)); janet_chan_init(tchan, limit, 1); return janet_wrap_abstract(tchan); } JANET_CORE_FN(cfun_channel_close, "(ev/chan-close chan)", "Close a channel. A closed channel will cause all pending reads and writes to return nil. " "Returns the channel.") { janet_fixarity(argc, 1); JanetChannel *channel = janet_getchannel(argv, 0); janet_chan_lock(channel); if (!channel->closed) { channel->closed = 1; JanetChannelPending writer; while (!janet_q_pop(&channel->write_pending, &writer, sizeof(writer))) { if (writer.thread != &janet_vm) { JanetVM *vm = writer.thread; JanetEVGenericMessage msg; msg.fiber = writer.fiber; msg.argp = channel; msg.tag = JANET_CP_MODE_CLOSE; msg.argi = (int32_t) writer.sched_id; msg.argj = janet_wrap_nil(); if (vm) { janet_ev_post_event(vm, janet_thread_chan_cb, msg); } } else { if (janet_fiber_can_resume(writer.fiber) && writer.sched_id == writer.fiber->sched_id) { if (writer.mode == JANET_CP_MODE_CHOICE_WRITE) { janet_schedule(writer.fiber, make_close_result(channel)); } else { janet_schedule(writer.fiber, janet_wrap_nil()); } } } } JanetChannelPending reader; while (!janet_q_pop(&channel->read_pending, &reader, sizeof(reader))) { if (reader.thread != &janet_vm) { JanetVM *vm = reader.thread; JanetEVGenericMessage msg; msg.fiber = reader.fiber; msg.argp = channel; msg.tag = JANET_CP_MODE_CLOSE; msg.argi = (int32_t) reader.sched_id; msg.argj = janet_wrap_nil(); if (vm) { janet_ev_post_event(vm, janet_thread_chan_cb, msg); } } else { if (janet_fiber_can_resume(reader.fiber) && reader.sched_id == reader.fiber->sched_id) { if (reader.mode == JANET_CP_MODE_CHOICE_READ) { janet_schedule(reader.fiber, make_close_result(channel)); } else { janet_schedule(reader.fiber, janet_wrap_nil()); } } } } } janet_chan_unlock(channel); return argv[0]; } static const JanetMethod ev_chanat_methods[] = { {"select", cfun_channel_choice}, {"rselect", cfun_channel_rchoice}, {"count", cfun_channel_count}, {"take", cfun_channel_pop}, {"give", cfun_channel_push}, {"capacity", cfun_channel_capacity}, {"full", cfun_channel_full}, {"close", cfun_channel_close}, {NULL, NULL} }; static int janet_chanat_get(void *p, Janet key, Janet *out) { (void) p; if (!janet_checktype(key, JANET_KEYWORD)) return 0; return janet_getmethod(janet_unwrap_keyword(key), ev_chanat_methods, out); } static Janet janet_chanat_next(void *p, Janet key) { (void) p; return janet_nextmethod(ev_chanat_methods, key); } static void janet_chanat_marshal(void *p, JanetMarshalContext *ctx) { JanetChannel *channel = (JanetChannel *)p; janet_marshal_byte(ctx, channel->is_threaded); janet_marshal_abstract(ctx, channel); janet_marshal_byte(ctx, channel->closed); janet_marshal_int(ctx, channel->limit); int32_t count = janet_q_count(&channel->items); janet_marshal_int(ctx, count); JanetQueue *items = &channel->items; Janet *data = channel->items.data; if (items->head <= items->tail) { for (int32_t i = items->head; i < items->tail; i++) janet_marshal_janet(ctx, data[i]); } else { for (int32_t i = items->head; i < items->capacity; i++) janet_marshal_janet(ctx, data[i]); for (int32_t i = 0; i < items->tail; i++) janet_marshal_janet(ctx, data[i]); } } static void *janet_chanat_unmarshal(JanetMarshalContext *ctx) { uint8_t is_threaded = janet_unmarshal_byte(ctx); JanetChannel *abst; if (is_threaded) { abst = janet_unmarshal_abstract_threaded(ctx, sizeof(JanetChannel)); } else { abst = janet_unmarshal_abstract(ctx, sizeof(JanetChannel)); } uint8_t is_closed = janet_unmarshal_byte(ctx); int32_t limit = janet_unmarshal_int(ctx); int32_t count = janet_unmarshal_int(ctx); if (count < 0) janet_panic("invalid negative channel count"); janet_chan_init(abst, limit, 0); abst->closed = !!is_closed; for (int32_t i = 0; i < count; i++) { Janet item = janet_unmarshal_janet(ctx); janet_q_push(&abst->items, &item, sizeof(item)); } return abst; } const JanetAbstractType janet_channel_type = { "core/channel", janet_chanat_gc, janet_chanat_mark, janet_chanat_get, NULL, /* put */ janet_chanat_marshal, janet_chanat_unmarshal, NULL, /* tostring */ NULL, /* compare */ NULL, /* hash */ janet_chanat_next, NULL, /* call */ NULL, /* length */ NULL, /* bytes */ janet_chanat_gcperthread }; /* Main event loop */ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout); int janet_loop_done(void) { return !((janet_vm.spawn.head != janet_vm.spawn.tail) || janet_vm.tq_count || janet_atomic_load(&janet_vm.listener_count)); } JanetFiber *janet_loop1(void) { /* Schedule expired timers */ JanetTimeout to; JanetTimestamp now = ts_now(); while (peek_timeout(&to) && to.when <= now) { pop_timeout(0); if (to.curr_fiber != NULL) { if (janet_fiber_can_resume(to.curr_fiber)) { janet_cancel(to.fiber, janet_cstringv("deadline expired")); } } else { /* This is a timeout (for a function call, not a whole fiber) */ if (to.fiber->sched_id == to.sched_id) { if (to.is_error) { janet_cancel(to.fiber, janet_cstringv("timeout")); } else { janet_schedule(to.fiber, janet_wrap_nil()); } } } handle_timeout_worker(to, 0); } /* Run scheduled fibers unless interrupts need to be handled. */ while (janet_vm.spawn.head != janet_vm.spawn.tail) { /* Don't run until all interrupts have been marked as handled by calling janet_interpreter_interrupt_handled */ if (janet_atomic_load_relaxed(&janet_vm.auto_suspend)) break; JanetTask task = {NULL, janet_wrap_nil(), JANET_SIGNAL_OK, 0}; janet_q_pop(&janet_vm.spawn, &task, sizeof(task)); if (task.fiber->gc.flags & JANET_FIBER_EV_FLAG_SUSPENDED) janet_ev_dec_refcount(); task.fiber->gc.flags &= ~(JANET_FIBER_EV_FLAG_CANCELED | JANET_FIBER_EV_FLAG_SUSPENDED); if (task.expected_sched_id != task.fiber->sched_id) continue; Janet res; JanetSignal sig = janet_continue_signal(task.fiber, task.value, &res, task.sig); if (!janet_fiber_can_resume(task.fiber)) { janet_table_remove(&janet_vm.active_tasks, janet_wrap_fiber(task.fiber)); } void *sv = task.fiber->supervisor_channel; int is_suspended = sig == JANET_SIGNAL_EVENT || sig == JANET_SIGNAL_YIELD || sig == JANET_SIGNAL_INTERRUPT; if (is_suspended) { task.fiber->gc.flags |= JANET_FIBER_EV_FLAG_SUSPENDED; janet_ev_inc_refcount(); } if (NULL == sv) { if (!is_suspended) { janet_stacktrace_ext(task.fiber, res, ""); } } else if (sig == JANET_SIGNAL_OK || (task.fiber->flags & (1 << sig))) { JanetChannel *chan = janet_channel_unwrap(sv); janet_channel_push(chan, make_supervisor_event(janet_signal_names[sig], task.fiber, chan->is_threaded), 2); } else if (!is_suspended) { janet_stacktrace_ext(task.fiber, res, ""); } if (sig == JANET_SIGNAL_INTERRUPT) { return task.fiber; } } /* Poll for events */ if (janet_vm.tq_count || janet_atomic_load(&janet_vm.listener_count)) { JanetTimeout to; memset(&to, 0, sizeof(to)); int has_timeout; /* Drop timeouts that are no longer needed */ while ((has_timeout = peek_timeout(&to))) { if (to.curr_fiber != NULL) { if (!janet_fiber_can_resume(to.curr_fiber)) { pop_timeout(0); janet_table_remove(&janet_vm.active_tasks, janet_wrap_fiber(to.curr_fiber)); handle_timeout_worker(to, 1); continue; } } else if (to.fiber->sched_id != to.sched_id) { pop_timeout(0); handle_timeout_worker(to, 1); continue; } break; } /* Run polling implementation only if pending timeouts or pending events */ if (janet_vm.tq_count || janet_atomic_load(&janet_vm.listener_count)) { janet_loop1_impl(has_timeout, to.when); } } /* No fiber was interrupted */ return NULL; } /* Same as janet_interpreter_interrupt, but will also * break out of the event loop if waiting for an event * (say, waiting for ev/sleep to finish). Does this by pushing * an empty event to the event loop. */ void janet_loop1_interrupt(JanetVM *vm) { janet_interpreter_interrupt(vm); JanetEVGenericMessage msg = {0}; JanetCallback cb = NULL; janet_ev_post_event(vm, cb, msg); } void janet_loop(void) { while (!janet_loop_done()) { JanetFiber *interrupted_fiber = janet_loop1(); if (NULL != interrupted_fiber) { janet_schedule(interrupted_fiber, janet_wrap_nil()); } } } /* * Self-pipe handling code. */ #ifdef JANET_WINDOWS /* On windows, use PostQueuedCompletionStatus instead for * custom events */ #else static void janet_ev_setup_selfpipe(void) { if (janet_make_pipe(janet_vm.selfpipe, 1)) { JANET_EXIT("failed to initialize self pipe in event loop"); } } /* Handle events from the self pipe inside the event loop */ static void janet_ev_handle_selfpipe(void) { JanetSelfPipeEvent response; int status; recur: do { status = read(janet_vm.selfpipe[0], &response, sizeof(response)); } while (status == -1 && errno == EINTR); if (status > 0) { if (NULL != response.cb) { response.cb(response.msg); janet_ev_dec_refcount(); } goto recur; } } static void janet_ev_cleanup_selfpipe(void) { close(janet_vm.selfpipe[0]); close(janet_vm.selfpipe[1]); } #endif #ifdef JANET_WINDOWS static JanetTimestamp ts_now(void) { return (JanetTimestamp) GetTickCount64(); } void janet_ev_init(void) { janet_ev_init_common(); janet_vm.iocp = CreateIoCompletionPort(INVALID_HANDLE_VALUE, NULL, 0, 0); if (NULL == janet_vm.iocp) janet_panic("could not create io completion port"); } void janet_ev_deinit(void) { janet_ev_deinit_common(); CloseHandle(janet_vm.iocp); } static void janet_register_stream(JanetStream *stream) { if (NULL == CreateIoCompletionPort(stream->handle, janet_vm.iocp, (ULONG_PTR) stream, 0)) { if (stream->flags & (JANET_STREAM_READABLE | JANET_STREAM_WRITABLE | JANET_STREAM_ACCEPTABLE)) { janet_panicf("failed to listen for events: %V", janet_ev_lasterr()); } stream->flags |= JANET_STREAM_UNREGISTERED; } } void janet_loop1_impl(int has_timeout, JanetTimestamp to) { ULONG_PTR completionKey = 0; DWORD num_bytes_transferred = 0; LPOVERLAPPED overlapped = NULL; /* Calculate how long to wait before timeout */ uint64_t waittime; if (has_timeout) { JanetTimestamp now = ts_now(); if (now > to) { waittime = 0; } else { waittime = (uint64_t)(to - now); } } else { waittime = INFINITE; } BOOL result = GetQueuedCompletionStatus(janet_vm.iocp, &num_bytes_transferred, &completionKey, &overlapped, (DWORD) waittime); if (result || overlapped) { if (0 == completionKey) { /* Custom event */ JanetSelfPipeEvent *response = (JanetSelfPipeEvent *)(overlapped); if (NULL != response->cb) { response->cb(response->msg); } janet_ev_dec_refcount(); janet_free(response); } else { /* Normal event */ JanetStream *stream = (JanetStream *) completionKey; JanetFiber *fiber = NULL; if (stream->read_fiber && stream->read_fiber->ev_state == overlapped) { fiber = stream->read_fiber; } else if (stream->write_fiber && stream->write_fiber->ev_state == overlapped) { fiber = stream->write_fiber; } if (fiber != NULL) { fiber->flags &= ~JANET_FIBER_EV_FLAG_IN_FLIGHT; /* System is done with this, we can reused this data */ overlapped->InternalHigh = (ULONG_PTR) num_bytes_transferred; fiber->ev_callback(fiber, result ? JANET_ASYNC_EVENT_COMPLETE : JANET_ASYNC_EVENT_FAILED); } else { janet_free((void *) overlapped); janet_ev_dec_refcount(); } janet_stream_checktoclose(stream); } } } void janet_stream_edge_triggered(JanetStream *stream) { (void) stream; } void janet_stream_level_triggered(JanetStream *stream) { (void) stream; } #elif defined(JANET_EV_EPOLL) static JanetTimestamp ts_now(void) { struct timespec now; janet_assert(-1 != janet_gettime(&now, JANET_TIME_MONOTONIC), "failed to get time"); uint64_t res = 1000 * now.tv_sec; res += now.tv_nsec / 1000000; return res; } /* Wait for the next event */ static void janet_register_stream_impl(JanetStream *stream, int mod, int edge_trigger) { struct epoll_event ev; ev.events = edge_trigger ? EPOLLET : 0; if (stream->flags & (JANET_STREAM_READABLE | JANET_STREAM_ACCEPTABLE)) ev.events |= EPOLLIN; if (stream->flags & JANET_STREAM_WRITABLE) ev.events |= EPOLLOUT; ev.data.ptr = stream; int status; do { status = epoll_ctl(janet_vm.epoll, mod ? EPOLL_CTL_MOD : EPOLL_CTL_ADD, stream->handle, &ev); } while (status == -1 && errno == EINTR); if (status == -1) { if (errno == EPERM) { /* Couldn't add to event loop, so assume that it completes * synchronously. */ stream->flags |= JANET_STREAM_UNREGISTERED; } else { /* Unexpected error */ janet_panicv(janet_ev_lasterr()); } } } static void janet_register_stream(JanetStream *stream) { janet_register_stream_impl(stream, 0, 1); } void janet_stream_edge_triggered(JanetStream *stream) { janet_register_stream_impl(stream, 1, 1); } void janet_stream_level_triggered(JanetStream *stream) { janet_register_stream_impl(stream, 1, 0); } #define JANET_EPOLL_MAX_EVENTS 64 void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { struct itimerspec its; if (janet_vm.timer_enabled || has_timeout) { memset(&its, 0, sizeof(its)); if (has_timeout) { its.it_value.tv_sec = timeout / 1000; its.it_value.tv_nsec = (timeout % 1000) * 1000000; } timerfd_settime(janet_vm.timerfd, TFD_TIMER_ABSTIME, &its, NULL); } janet_vm.timer_enabled = has_timeout; /* Poll for events */ struct epoll_event events[JANET_EPOLL_MAX_EVENTS]; int ready; do { ready = epoll_wait(janet_vm.epoll, events, JANET_EPOLL_MAX_EVENTS, -1); } while (ready == -1 && errno == EINTR); if (ready == -1) { JANET_EXIT("failed to poll events"); } /* Step state machines */ for (int i = 0; i < ready; i++) { void *p = events[i].data.ptr; if (&janet_vm.timerfd == p) { /* Timer expired, ignore */; } else if (janet_vm.selfpipe == p) { /* Self-pipe handling */ janet_ev_handle_selfpipe(); } else { JanetStream *stream = p; int mask = events[i].events; int has_err = mask & EPOLLERR; int has_hup = mask & EPOLLHUP; JanetFiber *rf = stream->read_fiber; JanetFiber *wf = stream->write_fiber; if (rf) { if (rf->ev_callback && (mask & EPOLLIN)) { rf->ev_callback(rf, JANET_ASYNC_EVENT_READ); } if (rf->ev_callback && has_err) { rf->ev_callback(rf, JANET_ASYNC_EVENT_ERR); } if (rf->ev_callback && has_hup) { rf->ev_callback(rf, JANET_ASYNC_EVENT_HUP); } } if (wf) { if (wf->ev_callback && (mask & EPOLLOUT)) { wf->ev_callback(wf, JANET_ASYNC_EVENT_WRITE); } if (wf->ev_callback && has_err) { wf->ev_callback(wf, JANET_ASYNC_EVENT_ERR); } if (wf->ev_callback && has_hup) { wf->ev_callback(wf, JANET_ASYNC_EVENT_HUP); } } janet_stream_checktoclose(stream); } } } void janet_ev_init(void) { janet_ev_init_common(); janet_ev_setup_selfpipe(); janet_vm.epoll = epoll_create1(EPOLL_CLOEXEC); janet_vm.timerfd = timerfd_create(CLOCK_MONOTONIC, TFD_CLOEXEC | TFD_NONBLOCK); janet_vm.timer_enabled = 0; if (janet_vm.epoll == -1 || janet_vm.timerfd == -1) goto error; struct epoll_event ev; ev.events = EPOLLIN | EPOLLET; ev.data.ptr = &janet_vm.timerfd; if (-1 == epoll_ctl(janet_vm.epoll, EPOLL_CTL_ADD, janet_vm.timerfd, &ev)) goto error; ev.events = EPOLLIN | EPOLLET; ev.data.ptr = janet_vm.selfpipe; if (-1 == epoll_ctl(janet_vm.epoll, EPOLL_CTL_ADD, janet_vm.selfpipe[0], &ev)) goto error; return; error: JANET_EXIT("failed to initialize event loop"); } void janet_ev_deinit(void) { janet_ev_deinit_common(); close(janet_vm.epoll); close(janet_vm.timerfd); janet_ev_cleanup_selfpipe(); janet_vm.epoll = 0; } /* * End epoll implementation */ #elif defined(JANET_EV_KQUEUE) /* Definition from: * https://github.com/wahern/cqueues/blob/master/src/lib/kpoll.c * NetBSD uses intptr_t while others use void * for .udata */ #define EV_SETx(ev, a, b, c, d, e, f) EV_SET((ev), (a), (b), (c), (d), (e), ((__typeof__((ev)->udata))(f))) #define JANET_KQUEUE_MIN_INTERVAL 0 /* NOTE: * NetBSD and OpenBSD expect things are always intervals, and FreeBSD doesn't * like an ABSTIME in the past so just use intervals always. Introduces a * calculation to determine the minimum timeout per timeout requested of * kqueue. Also note that NetBSD doesn't accept timeout intervals less than 1 * millisecond, so correct all intervals on that platform to be at least 1 * millisecond.*/ JanetTimestamp to_interval(const JanetTimestamp ts) { return ts >= JANET_KQUEUE_MIN_INTERVAL ? ts : JANET_KQUEUE_MIN_INTERVAL; } #define JANET_KQUEUE_INTERVAL(timestamp) (to_interval((timestamp - ts_now()))) static JanetTimestamp ts_now(void) { struct timespec now; janet_assert(-1 != janet_gettime(&now, JANET_TIME_MONOTONIC), "failed to get time"); uint64_t res = 1000 * now.tv_sec; res += now.tv_nsec / 1000000; return res; } /* NOTE: Assumes Janet's timestamp precision is in milliseconds. */ static void timestamp2timespec(struct timespec *t, JanetTimestamp ts) { t->tv_sec = ts == 0 ? 0 : ts / 1000; t->tv_nsec = ts == 0 ? 0 : (ts % 1000) * 1000000; } void janet_register_stream_impl(JanetStream *stream, int edge_trigger) { struct kevent kevs[2]; int length = 0; int clear = edge_trigger ? EV_CLEAR : 0; if (stream->flags & (JANET_STREAM_READABLE | JANET_STREAM_ACCEPTABLE)) { EV_SETx(&kevs[length++], stream->handle, EVFILT_READ, EV_ADD | EV_ENABLE | clear, 0, 0, stream); } if (stream->flags & JANET_STREAM_WRITABLE) { EV_SETx(&kevs[length++], stream->handle, EVFILT_WRITE, EV_ADD | EV_ENABLE | clear, 0, 0, stream); } int status; do { status = kevent(janet_vm.kq, kevs, length, NULL, 0, NULL); } while (status == -1 && errno == EINTR); if (status == -1) { stream->flags |= JANET_STREAM_UNREGISTERED; } } void janet_register_stream(JanetStream *stream) { janet_register_stream_impl(stream, 1); } void janet_stream_edge_triggered(JanetStream *stream) { janet_register_stream_impl(stream, 1); } void janet_stream_level_triggered(JanetStream *stream) { /* On macos, we seem to need to delete any registered events before re-registering without * EV_CLEAR, otherwise the new event will still have EV_CLEAR set erroneously. This could be a * kernel bug, but unfortunately the specification is vague here, esp. in regards to where and when * EV_CLEAR is set automatically. */ struct kevent kevs[2]; int length = 0; if (stream->flags & (JANET_STREAM_READABLE | JANET_STREAM_ACCEPTABLE)) { EV_SETx(&kevs[length++], stream->handle, EVFILT_READ, EV_DELETE, 0, 0, stream); } if (stream->flags & JANET_STREAM_WRITABLE) { EV_SETx(&kevs[length++], stream->handle, EVFILT_WRITE, EV_DELETE, 0, 0, stream); } int status; do { status = kevent(janet_vm.kq, kevs, length, NULL, 0, NULL); } while (status == -1 && errno == EINTR); janet_register_stream_impl(stream, 0); } #define JANET_KQUEUE_MAX_EVENTS 64 void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { /* Poll for events */ /* NOTE: * We calculate the timeout interval per iteration. When the interval * drops to 0 or negative, we effect a timeout of 0. Effecting a timeout * of infinity will not work and could make other fibers with timeouts * miss their timeouts if we did so. * JANET_KQUEUE_INTERVAL insures we have a timeout of no less than 0. */ int status; struct timespec ts; struct kevent events[JANET_KQUEUE_MAX_EVENTS]; do { if (janet_vm.timer_enabled || has_timeout) { timestamp2timespec(&ts, JANET_KQUEUE_INTERVAL(timeout)); status = kevent(janet_vm.kq, NULL, 0, events, JANET_KQUEUE_MAX_EVENTS, &ts); } else { status = kevent(janet_vm.kq, NULL, 0, events, JANET_KQUEUE_MAX_EVENTS, NULL); } } while (status == -1 && errno == EINTR); if (status == -1) { JANET_EXIT("failed to poll events"); } /* Make sure timer is set accordingly. */ janet_vm.timer_enabled = has_timeout; /* Step state machines */ for (int i = 0; i < status; i++) { void *p = (void *) events[i].udata; if (janet_vm.selfpipe == p) { /* Self-pipe handling */ janet_ev_handle_selfpipe(); } else { JanetStream *stream = p; int filt = events[i].filter; int has_err = events[i].flags & EV_ERROR; int has_hup = events[i].flags & EV_EOF; for (int j = 0; j < 2; j++) { JanetFiber *f = j ? stream->read_fiber : stream->write_fiber; if (!f) continue; if (f->ev_callback && has_err) { f->ev_callback(f, JANET_ASYNC_EVENT_ERR); } if (f->ev_callback && (filt == EVFILT_READ) && f == stream->read_fiber) { f->ev_callback(f, JANET_ASYNC_EVENT_READ); } if (f->ev_callback && (filt == EVFILT_WRITE) && f == stream->write_fiber) { f->ev_callback(f, JANET_ASYNC_EVENT_WRITE); } if (f->ev_callback && has_hup) { f->ev_callback(f, JANET_ASYNC_EVENT_HUP); } } janet_stream_checktoclose(stream); } } } void janet_ev_init(void) { janet_ev_init_common(); janet_ev_setup_selfpipe(); janet_vm.kq = kqueue(); janet_vm.timer_enabled = 0; if (janet_vm.kq == -1) goto error; struct kevent event; EV_SETx(&event, janet_vm.selfpipe[0], EVFILT_READ, EV_ADD | EV_ENABLE, 0, 0, janet_vm.selfpipe); int status; do { status = kevent(janet_vm.kq, &event, 1, NULL, 0, NULL); } while (status == -1 && errno != EINTR); if (status == -1) goto error; return; error: JANET_EXIT("failed to initialize event loop"); } void janet_ev_deinit(void) { janet_ev_deinit_common(); close(janet_vm.kq); janet_ev_cleanup_selfpipe(); janet_vm.kq = 0; } #elif defined(JANET_EV_POLL) /* Simple poll implementation. Efficiency is not the goal here, although the poll implementation should be farily efficient * for low numbers of concurrent file descriptors. Rather, the code should be simple, portable, correct, and mirror the * epoll and kqueue code. */ static JanetTimestamp ts_now(void) { struct timespec now; janet_assert(-1 != janet_gettime(&now, JANET_TIME_MONOTONIC), "failed to get time"); uint64_t res = 1000 * now.tv_sec; res += now.tv_nsec / 1000000; return res; } /* Wait for the next event */ void janet_register_stream(JanetStream *stream) { struct pollfd ev = {0}; stream->index = (uint32_t) janet_vm.stream_count; size_t new_count = janet_vm.stream_count + 1; if (new_count > janet_vm.stream_capacity) { size_t new_cap = new_count * 2; janet_vm.fds = janet_realloc(janet_vm.fds, (1 + new_cap) * sizeof(struct pollfd)); janet_vm.streams = janet_realloc(janet_vm.streams, new_cap * sizeof(JanetStream *)); if (!janet_vm.fds || !janet_vm.streams) { JANET_OUT_OF_MEMORY; } janet_vm.stream_capacity = new_cap; } ev.fd = stream->handle; ev.events = POLLIN | POLLOUT; janet_vm.fds[janet_vm.stream_count + 1] = ev; janet_vm.streams[janet_vm.stream_count] = stream; janet_vm.stream_count = new_count; } void janet_stream_edge_triggered(JanetStream *stream) { (void) stream; } void janet_stream_level_triggered(JanetStream *stream) { (void) stream; } void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { /* set event flags */ for (size_t i = 0; i < janet_vm.stream_count; i++) { JanetStream *stream = janet_vm.streams[i]; struct pollfd *pfd = janet_vm.fds + i + 1; pfd->events = 0; pfd->revents = 0; JanetFiber *rf = stream->read_fiber; JanetFiber *wf = stream->write_fiber; if (rf && rf->ev_callback) pfd->events |= POLLIN; if (wf && wf->ev_callback) pfd->events |= POLLOUT; /* Hack to ignore a file descriptor - make file descriptor negative if we want to ignore */ if (!pfd->events) { pfd->fd = -pfd->fd; } } /* Poll for events */ int ready; do { int to = -1; if (has_timeout) { JanetTimestamp now = ts_now(); to = now > timeout ? 0 : (int)(timeout - now); } ready = poll(janet_vm.fds, janet_vm.stream_count + 1, to); } while (ready == -1 && errno == EINTR); if (ready == -1) { JANET_EXIT("failed to poll events"); } /* Undo negative hack */ for (size_t i = 0; i < janet_vm.stream_count; i++) { struct pollfd *pfd = janet_vm.fds + i + 1; if (pfd->fd < 0) { pfd->fd = -pfd->fd; } } /* Check selfpipe */ if (janet_vm.fds[0].revents & POLLIN) { janet_vm.fds[0].revents = 0; janet_ev_handle_selfpipe(); } /* Step state machines */ for (size_t i = 0; i < janet_vm.stream_count; i++) { struct pollfd *pfd = janet_vm.fds + i + 1; JanetStream *stream = janet_vm.streams[i]; int mask = pfd->revents; if (!mask) continue; int has_err = mask & POLLERR; int has_hup = mask & POLLHUP; JanetFiber *rf = stream->read_fiber; JanetFiber *wf = stream->write_fiber; if (rf) { if (rf->ev_callback && (mask & POLLIN)) { rf->ev_callback(rf, JANET_ASYNC_EVENT_READ); } else if (rf->ev_callback && has_hup) { rf->ev_callback(rf, JANET_ASYNC_EVENT_HUP); } else if (rf->ev_callback && has_err) { rf->ev_callback(rf, JANET_ASYNC_EVENT_ERR); } } if (wf) { if (wf->ev_callback && (mask & POLLOUT)) { wf->ev_callback(wf, JANET_ASYNC_EVENT_WRITE); } else if (wf->ev_callback && has_hup) { wf->ev_callback(wf, JANET_ASYNC_EVENT_HUP); } else if (wf->ev_callback && has_err) { wf->ev_callback(wf, JANET_ASYNC_EVENT_ERR); } } janet_stream_checktoclose(stream); } } void janet_ev_init(void) { janet_ev_init_common(); janet_vm.fds = NULL; janet_ev_setup_selfpipe(); janet_vm.fds = janet_malloc(sizeof(struct pollfd)); if (NULL == janet_vm.fds) { JANET_OUT_OF_MEMORY; } janet_vm.fds[0].fd = janet_vm.selfpipe[0]; janet_vm.fds[0].events = POLLIN; janet_vm.fds[0].revents = 0; janet_vm.streams = NULL; janet_vm.stream_count = 0; janet_vm.stream_capacity = 0; return; } void janet_ev_deinit(void) { janet_ev_deinit_common(); janet_ev_cleanup_selfpipe(); janet_free(janet_vm.fds); janet_free(janet_vm.streams); janet_vm.fds = NULL; janet_vm.streams = NULL; } #endif /* * End poll implementation */ /* * Generic Callback system. Post a function pointer + data to the event loop (from another * thread or even a signal handler). Allows posting events from another thread or signal handler. */ void janet_ev_post_event(JanetVM *vm, JanetCallback cb, JanetEVGenericMessage msg) { vm = vm ? vm : &janet_vm; janet_atomic_inc(&vm->listener_count); #ifdef JANET_WINDOWS JanetHandle iocp = vm->iocp; JanetSelfPipeEvent *event = janet_malloc(sizeof(JanetSelfPipeEvent)); if (NULL == event) { JANET_OUT_OF_MEMORY; } event->msg = msg; event->cb = cb; janet_assert(PostQueuedCompletionStatus(iocp, sizeof(JanetSelfPipeEvent), 0, (LPOVERLAPPED) event), "failed to post completion event"); #else JanetSelfPipeEvent event; memset(&event, 0, sizeof(event)); event.msg = msg; event.cb = cb; int fd = vm->selfpipe[1]; /* handle a bit of back pressure before giving up. */ int tries = 20; while (tries > 0) { int status; do { status = write(fd, &event, sizeof(event)); } while (status == -1 && errno == EINTR); if (status > 0) break; sleep(0); tries--; } janet_assert(tries > 0, "failed to write event to self-pipe"); #endif } /* * Threaded calls */ #ifdef JANET_WINDOWS static DWORD WINAPI janet_thread_body(LPVOID ptr) { JanetEVThreadInit *init = (JanetEVThreadInit *)ptr; JanetEVGenericMessage msg = init->msg; JanetThreadedSubroutine subr = init->subr; JanetThreadedCallback cb = init->cb; JanetHandle iocp = init->write_pipe; /* Reuse memory from thread init for returning data */ init->msg = subr(msg); init->cb = cb; janet_assert(PostQueuedCompletionStatus(iocp, sizeof(JanetSelfPipeEvent), 0, (LPOVERLAPPED) init), "failed to post completion event"); return 0; } #else static void *janet_thread_body(void *ptr) { JanetEVThreadInit *init = (JanetEVThreadInit *)ptr; JanetEVGenericMessage msg = init->msg; JanetThreadedSubroutine subr = init->subr; JanetThreadedCallback cb = init->cb; int fd = init->write_pipe; janet_free(init); JanetSelfPipeEvent response; memset(&response, 0, sizeof(response)); response.msg = subr(msg); response.cb = cb; /* handle a bit of back pressure before giving up. */ int tries = 4; while (tries > 0) { int status; do { status = write(fd, &response, sizeof(response)); } while (status == -1 && errno == EINTR); if (status > 0) break; sleep(1); tries--; } return NULL; } #endif void janet_ev_threaded_call(JanetThreadedSubroutine fp, JanetEVGenericMessage arguments, JanetThreadedCallback cb) { JanetEVThreadInit *init = janet_malloc(sizeof(JanetEVThreadInit)); if (NULL == init) { JANET_OUT_OF_MEMORY; } init->msg = arguments; init->subr = fp; init->cb = cb; #ifdef JANET_WINDOWS init->write_pipe = janet_vm.iocp; HANDLE thread_handle = CreateThread(NULL, 0, janet_thread_body, init, 0, NULL); if (NULL == thread_handle) { janet_free(init); janet_panic("failed to create thread"); } CloseHandle(thread_handle); /* detach from thread */ #else init->write_pipe = janet_vm.selfpipe[1]; pthread_t waiter_thread; int err = pthread_create(&waiter_thread, &janet_vm.new_thread_attr, janet_thread_body, init); if (err) { janet_free(init); janet_panicf("%s", janet_strerror(err)); } #endif /* Increment ev refcount so we don't quit while waiting for a subprocess */ janet_ev_inc_refcount(); } /* Default callback for janet_ev_threaded_await. */ void janet_ev_default_threaded_callback(JanetEVGenericMessage return_value) { if (return_value.fiber == NULL) { return; } if (janet_fiber_can_resume(return_value.fiber)) { switch (return_value.tag) { default: case JANET_EV_TCTAG_NIL: janet_schedule(return_value.fiber, janet_wrap_nil()); break; case JANET_EV_TCTAG_INTEGER: janet_schedule(return_value.fiber, janet_wrap_integer(return_value.argi)); break; case JANET_EV_TCTAG_STRING: case JANET_EV_TCTAG_STRINGF: janet_schedule(return_value.fiber, janet_cstringv((const char *) return_value.argp)); if (return_value.tag == JANET_EV_TCTAG_STRINGF) janet_free(return_value.argp); break; case JANET_EV_TCTAG_KEYWORD: janet_schedule(return_value.fiber, janet_ckeywordv((const char *) return_value.argp)); break; case JANET_EV_TCTAG_ERR_STRING: case JANET_EV_TCTAG_ERR_STRINGF: janet_cancel(return_value.fiber, janet_cstringv((const char *) return_value.argp)); if (return_value.tag == JANET_EV_TCTAG_STRINGF) janet_free(return_value.argp); break; case JANET_EV_TCTAG_ERR_KEYWORD: janet_cancel(return_value.fiber, janet_ckeywordv((const char *) return_value.argp)); break; case JANET_EV_TCTAG_BOOLEAN: janet_schedule(return_value.fiber, janet_wrap_boolean(return_value.argi)); break; } } janet_gcunroot(janet_wrap_fiber(return_value.fiber)); } /* Convenience method for common case */ JANET_NO_RETURN void janet_ev_threaded_await(JanetThreadedSubroutine fp, int tag, int argi, void *argp) { JanetEVGenericMessage arguments; memset(&arguments, 0, sizeof(arguments)); arguments.tag = tag; arguments.argi = argi; arguments.argp = argp; arguments.fiber = janet_root_fiber(); janet_gcroot(janet_wrap_fiber(arguments.fiber)); janet_ev_threaded_call(fp, arguments, janet_ev_default_threaded_callback); janet_await(); } /* * C API helpers for reading and writing from streams. * There is some networking code in here as well as generic * reading and writing primitives. */ void janet_stream_flags(JanetStream *stream, uint32_t flags) { if (stream->flags & JANET_STREAM_CLOSED) { janet_panic("stream is closed"); } if ((stream->flags & flags) != flags) { const char *rmsg = "", *wmsg = "", *amsg = "", *dmsg = "", *smsg = "stream"; if (flags & JANET_STREAM_READABLE) rmsg = "readable "; if (flags & JANET_STREAM_WRITABLE) wmsg = "writable "; if (flags & JANET_STREAM_ACCEPTABLE) amsg = "server "; if (flags & JANET_STREAM_UDPSERVER) dmsg = "datagram "; if (flags & JANET_STREAM_SOCKET) smsg = "socket"; janet_panicf("bad stream, expected %s%s%s%s%s", rmsg, wmsg, amsg, dmsg, smsg); } } /* When there is an IO error, we need to be able to convert it to a Janet * string to raise a Janet error. */ #ifdef JANET_WINDOWS #define JANET_EV_CHUNKSIZE 4096 Janet janet_ev_lasterr(void) { int code = GetLastError(); char msgbuf[256]; msgbuf[0] = '\0'; FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, NULL, code, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), msgbuf, sizeof(msgbuf), NULL); if (!*msgbuf) snprintf(msgbuf, sizeof(msgbuf), "%d", code); char *c = msgbuf; while (*c) { if (*c == '\n' || *c == '\r') { *c = '\0'; break; } c++; } return janet_cstringv(msgbuf); } #else Janet janet_ev_lasterr(void) { return janet_cstringv(janet_strerror(errno)); } #endif /* State machine for read/recv/recvfrom */ typedef enum { JANET_ASYNC_READMODE_READ, JANET_ASYNC_READMODE_RECV, JANET_ASYNC_READMODE_RECVFROM } JanetReadMode; typedef struct { #ifdef JANET_WINDOWS OVERLAPPED overlapped; DWORD flags; #ifdef JANET_NET WSABUF wbuf; struct sockaddr from; int fromlen; #endif uint8_t chunk_buf[JANET_EV_CHUNKSIZE]; #else int flags; #endif int32_t bytes_left; int32_t bytes_read; JanetBuffer *buf; int is_chunk; JanetReadMode mode; } StateRead; void ev_callback_read(JanetFiber *fiber, JanetAsyncEvent event) { JanetStream *stream = fiber->ev_stream; StateRead *state = (StateRead *) fiber->ev_state; switch (event) { default: break; case JANET_ASYNC_EVENT_MARK: janet_mark(janet_wrap_buffer(state->buf)); break; case JANET_ASYNC_EVENT_CLOSE: janet_schedule(fiber, janet_wrap_nil()); janet_async_end(fiber); break; #ifdef JANET_WINDOWS case JANET_ASYNC_EVENT_FAILED: case JANET_ASYNC_EVENT_COMPLETE: { /* Called when read finished */ uint32_t ev_bytes = (uint32_t) state->overlapped.InternalHigh; state->bytes_read += ev_bytes; if (state->bytes_read == 0 && (state->mode != JANET_ASYNC_READMODE_RECVFROM)) { janet_schedule(fiber, janet_wrap_nil()); janet_async_end(fiber); return; } janet_buffer_push_bytes(state->buf, state->chunk_buf, ev_bytes); state->bytes_left -= ev_bytes; if (state->bytes_left == 0 || !state->is_chunk || ev_bytes == 0) { Janet resume_val; #ifdef JANET_NET if (state->mode == JANET_ASYNC_READMODE_RECVFROM) { void *abst = janet_abstract(&janet_address_type, state->fromlen); memcpy(abst, &state->from, state->fromlen); resume_val = janet_wrap_abstract(abst); } else #endif { resume_val = janet_wrap_buffer(state->buf); } janet_schedule(fiber, resume_val); janet_async_end(fiber); return; } } /* fallthrough */ case JANET_ASYNC_EVENT_INIT: { int32_t chunk_size = state->bytes_left > JANET_EV_CHUNKSIZE ? JANET_EV_CHUNKSIZE : state->bytes_left; memset(&(state->overlapped), 0, sizeof(OVERLAPPED)); int status; #ifdef JANET_NET if (state->mode == JANET_ASYNC_READMODE_RECVFROM) { state->wbuf.len = (ULONG) chunk_size; state->wbuf.buf = (char *) state->chunk_buf; state->fromlen = sizeof(state->from); status = WSARecvFrom((SOCKET) stream->handle, &state->wbuf, 1, NULL, &state->flags, &state->from, &state->fromlen, &state->overlapped, NULL); if (status && (WSA_IO_PENDING != WSAGetLastError())) { janet_cancel(fiber, janet_ev_lasterr()); janet_async_end(fiber); return; } } else #endif { /* Some handles (not all) read from the offset in lpOverlapped * if its not set before calling `ReadFile` these streams will always read from offset 0 */ state->overlapped.Offset = (DWORD) state->bytes_read; status = ReadFile(stream->handle, state->chunk_buf, chunk_size, NULL, &state->overlapped); if (!status && (ERROR_IO_PENDING != GetLastError())) { if (GetLastError() == ERROR_BROKEN_PIPE) { if (state->bytes_read) { janet_schedule(fiber, janet_wrap_buffer(state->buf)); } else { janet_schedule(fiber, janet_wrap_nil()); } } else { janet_cancel(fiber, janet_ev_lasterr()); } janet_async_end(fiber); return; } } janet_async_in_flight(fiber); } break; #else case JANET_ASYNC_EVENT_ERR: { if (state->bytes_read) { janet_schedule(fiber, janet_wrap_buffer(state->buf)); } else { janet_schedule(fiber, janet_wrap_nil()); } stream->read_fiber = NULL; janet_async_end(fiber); break; } read_more: case JANET_ASYNC_EVENT_HUP: case JANET_ASYNC_EVENT_INIT: case JANET_ASYNC_EVENT_READ: { JanetBuffer *buffer = state->buf; int32_t bytes_left = state->bytes_left; int32_t read_limit = state->is_chunk ? (bytes_left > 4096 ? 4096 : bytes_left) : bytes_left; janet_buffer_extra(buffer, read_limit); ssize_t nread; #ifdef JANET_NET char saddr[256]; socklen_t socklen = sizeof(saddr); #endif do { #ifdef JANET_NET if (state->mode == JANET_ASYNC_READMODE_RECVFROM) { nread = recvfrom(stream->handle, buffer->data + buffer->count, read_limit, state->flags, (struct sockaddr *)&saddr, &socklen); } else if (state->mode == JANET_ASYNC_READMODE_RECV) { nread = recv(stream->handle, buffer->data + buffer->count, read_limit, state->flags); } else #endif { nread = read(stream->handle, buffer->data + buffer->count, read_limit); } } while (nread == -1 && errno == EINTR); /* Check for errors - special case errors that can just be waited on to fix */ if (nread == -1) { if (errno == EAGAIN || errno == EWOULDBLOCK) { break; } /* In stream protocols, a pipe error is end of stream */ if (errno == EPIPE && (state->mode != JANET_ASYNC_READMODE_RECVFROM)) { nread = 0; } else { janet_cancel(fiber, janet_ev_lasterr()); janet_async_end(fiber); break; } } /* Only allow 0-length packets in recv-from. In stream protocols, a zero length packet is EOS. */ state->bytes_read += nread; if (state->bytes_read == 0 && (state->mode != JANET_ASYNC_READMODE_RECVFROM)) { janet_schedule(fiber, janet_wrap_nil()); janet_async_end(fiber); break; } /* Increment buffer counts */ buffer->count += nread; bytes_left -= nread; state->bytes_left = bytes_left; /* Resume if done */ if (!state->is_chunk || bytes_left == 0 || nread == 0) { Janet resume_val; #ifdef JANET_NET if (state->mode == JANET_ASYNC_READMODE_RECVFROM) { void *abst = janet_abstract(&janet_address_type, socklen); memcpy(abst, &saddr, socklen); resume_val = janet_wrap_abstract(abst); } else #endif { resume_val = janet_wrap_buffer(buffer); } janet_schedule(fiber, resume_val); janet_async_end(fiber); break; } /* Read some more if possible */ goto read_more; } break; #endif } } static JANET_NO_RETURN void janet_ev_read_generic(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int is_chunked, JanetReadMode mode, int flags) { StateRead *state = janet_malloc(sizeof(StateRead)); state->is_chunk = is_chunked; state->buf = buf; state->bytes_left = nbytes; state->bytes_read = 0; state->mode = mode; #ifdef JANET_WINDOWS state->flags = (DWORD) flags; #else state->flags = flags; #endif janet_async_start(stream, JANET_ASYNC_LISTEN_READ, ev_callback_read, state); } JANET_NO_RETURN void janet_ev_read(JanetStream *stream, JanetBuffer *buf, int32_t nbytes) { janet_ev_read_generic(stream, buf, nbytes, 0, JANET_ASYNC_READMODE_READ, 0); } JANET_NO_RETURN void janet_ev_readchunk(JanetStream *stream, JanetBuffer *buf, int32_t nbytes) { janet_ev_read_generic(stream, buf, nbytes, 1, JANET_ASYNC_READMODE_READ, 0); } #ifdef JANET_NET JANET_NO_RETURN void janet_ev_recv(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int flags) { janet_ev_read_generic(stream, buf, nbytes, 0, JANET_ASYNC_READMODE_RECV, flags); } JANET_NO_RETURN void janet_ev_recvchunk(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int flags) { janet_ev_read_generic(stream, buf, nbytes, 1, JANET_ASYNC_READMODE_RECV, flags); } JANET_NO_RETURN void janet_ev_recvfrom(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int flags) { janet_ev_read_generic(stream, buf, nbytes, 0, JANET_ASYNC_READMODE_RECVFROM, flags); } #endif /* * State machine for write/send/send-to */ typedef enum { JANET_ASYNC_WRITEMODE_WRITE, JANET_ASYNC_WRITEMODE_SEND, JANET_ASYNC_WRITEMODE_SENDTO } JanetWriteMode; typedef struct { #ifdef JANET_WINDOWS OVERLAPPED overlapped; DWORD flags; #ifdef JANET_NET WSABUF wbuf; #endif #else int flags; int32_t start; #endif union { JanetBuffer *buf; const uint8_t *str; } src; int is_buffer; JanetWriteMode mode; void *dest_abst; } StateWrite; void ev_callback_write(JanetFiber *fiber, JanetAsyncEvent event) { JanetStream *stream = fiber->ev_stream; StateWrite *state = (StateWrite *) fiber->ev_state; switch (event) { default: break; case JANET_ASYNC_EVENT_MARK: { janet_mark(state->is_buffer ? janet_wrap_buffer(state->src.buf) : janet_wrap_string(state->src.str)); if (state->mode == JANET_ASYNC_WRITEMODE_SENDTO) { janet_mark(janet_wrap_abstract(state->dest_abst)); } break; } case JANET_ASYNC_EVENT_CLOSE: janet_cancel(fiber, janet_cstringv("stream closed")); janet_async_end(fiber); break; #ifdef JANET_WINDOWS case JANET_ASYNC_EVENT_FAILED: case JANET_ASYNC_EVENT_COMPLETE: { /* Called when write finished */ uint32_t ev_bytes = (uint32_t) state->overlapped.InternalHigh; if (ev_bytes == 0 && (state->mode != JANET_ASYNC_WRITEMODE_SENDTO)) { janet_cancel(fiber, janet_cstringv("disconnect")); janet_async_end(fiber); return; } janet_schedule(fiber, janet_wrap_nil()); janet_async_end(fiber); return; } break; case JANET_ASYNC_EVENT_INIT: { /* Begin write */ int32_t len; const uint8_t *bytes; if (state->is_buffer) { /* If buffer, convert to string. */ /* TODO - be more efficient about this */ JanetBuffer *buffer = state->src.buf; JanetString str = janet_string(buffer->data, buffer->count); bytes = str; len = buffer->count; state->is_buffer = 0; state->src.str = str; } else { bytes = state->src.str; len = janet_string_length(bytes); } memset(&(state->overlapped), 0, sizeof(WSAOVERLAPPED)); int status; #ifdef JANET_NET if (state->mode == JANET_ASYNC_WRITEMODE_SENDTO) { SOCKET sock = (SOCKET) stream->handle; state->wbuf.buf = (char *) bytes; state->wbuf.len = len; const struct sockaddr *to = state->dest_abst; int tolen = (int) janet_abstract_size((void *) to); status = WSASendTo(sock, &state->wbuf, 1, NULL, state->flags, to, tolen, &state->overlapped, NULL); if (status) { if (WSA_IO_PENDING == WSAGetLastError()) { janet_async_in_flight(fiber); } else { janet_cancel(fiber, janet_ev_lasterr()); janet_async_end(fiber); return; } } } else #endif { /* * File handles in IOCP need to specify this if they are writing to the * ends of files, like how this is used here. * If the underlying resource doesn't support seeking * byte offsets, they will be ignored * but this otherwise writes to the end of the file in question * Right now, os/open streams aren't seekable, so this works. * for more details see the lpOverlapped parameter in * https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-writefile */ state->overlapped.Offset = (DWORD) 0xFFFFFFFF; state->overlapped.OffsetHigh = (DWORD) 0xFFFFFFFF; status = WriteFile(stream->handle, bytes, len, NULL, &state->overlapped); if (!status) { if (ERROR_IO_PENDING == GetLastError()) { janet_async_in_flight(fiber); } else { janet_cancel(fiber, janet_ev_lasterr()); janet_async_end(fiber); return; } } } } break; #else case JANET_ASYNC_EVENT_ERR: janet_cancel(fiber, janet_cstringv("stream err")); janet_async_end(fiber); break; case JANET_ASYNC_EVENT_HUP: janet_cancel(fiber, janet_cstringv("stream hup")); janet_async_end(fiber); break; case JANET_ASYNC_EVENT_INIT: case JANET_ASYNC_EVENT_WRITE: { int32_t start, len; const uint8_t *bytes; start = state->start; if (state->is_buffer) { JanetBuffer *buffer = state->src.buf; bytes = buffer->data; len = buffer->count; } else { bytes = state->src.str; len = janet_string_length(bytes); } ssize_t nwrote = 0; if (start < len) { int32_t nbytes = len - start; void *dest_abst = state->dest_abst; do { #ifdef JANET_NET if (state->mode == JANET_ASYNC_WRITEMODE_SENDTO) { nwrote = sendto(stream->handle, bytes + start, nbytes, state->flags, (struct sockaddr *) dest_abst, janet_abstract_size(dest_abst)); } else if (state->mode == JANET_ASYNC_WRITEMODE_SEND) { nwrote = send(stream->handle, bytes + start, nbytes, state->flags); } else #endif { nwrote = write(stream->handle, bytes + start, nbytes); } } while (nwrote == -1 && errno == EINTR); /* Handle write errors */ if (nwrote == -1) { if (errno == EAGAIN || errno == EWOULDBLOCK) break; janet_cancel(fiber, janet_ev_lasterr()); janet_async_end(fiber); break; } /* Unless using datagrams, empty message is a disconnect */ if (nwrote == 0 && !dest_abst) { janet_cancel(fiber, janet_cstringv("disconnect")); janet_async_end(fiber); break; } if (nwrote > 0) { start += nwrote; } else { start = len; } } state->start = start; if (start >= len) { janet_schedule(fiber, janet_wrap_nil()); janet_async_end(fiber); break; } break; } break; #endif } } static JANET_NO_RETURN void janet_ev_write_generic(JanetStream *stream, void *buf, void *dest_abst, JanetWriteMode mode, int is_buffer, int flags) { StateWrite *state = janet_malloc(sizeof(StateWrite)); state->is_buffer = is_buffer; state->src.buf = buf; state->dest_abst = dest_abst; state->mode = mode; #ifdef JANET_WINDOWS state->flags = (DWORD) flags; #else state->flags = flags; state->start = 0; #endif janet_async_start(stream, JANET_ASYNC_LISTEN_WRITE, ev_callback_write, state); } JANET_NO_RETURN void janet_ev_write_buffer(JanetStream *stream, JanetBuffer *buf) { janet_ev_write_generic(stream, buf, NULL, JANET_ASYNC_WRITEMODE_WRITE, 1, 0); } JANET_NO_RETURN void janet_ev_write_string(JanetStream *stream, JanetString str) { janet_ev_write_generic(stream, (void *) str, NULL, JANET_ASYNC_WRITEMODE_WRITE, 0, 0); } #ifdef JANET_NET JANET_NO_RETURN void janet_ev_send_buffer(JanetStream *stream, JanetBuffer *buf, int flags) { janet_ev_write_generic(stream, buf, NULL, JANET_ASYNC_WRITEMODE_SEND, 1, flags); } JANET_NO_RETURN void janet_ev_send_string(JanetStream *stream, JanetString str, int flags) { janet_ev_write_generic(stream, (void *) str, NULL, JANET_ASYNC_WRITEMODE_SEND, 0, flags); } JANET_NO_RETURN void janet_ev_sendto_buffer(JanetStream *stream, JanetBuffer *buf, void *dest, int flags) { janet_ev_write_generic(stream, buf, dest, JANET_ASYNC_WRITEMODE_SENDTO, 1, flags); } JANET_NO_RETURN void janet_ev_sendto_string(JanetStream *stream, JanetString str, void *dest, int flags) { janet_ev_write_generic(stream, (void *) str, dest, JANET_ASYNC_WRITEMODE_SENDTO, 0, flags); } #endif /* For a pipe ID */ #ifdef JANET_WINDOWS static volatile long PipeSerialNumber; #endif /* * mode = 0: both sides non-blocking. * mode = 1: only read side non-blocking: write side sent to subprocess * mode = 2: only write side non-blocking: read side sent to subprocess * mode = 3: both sides blocking - for use in two subprocesses (making pipeline from external processes) */ int janet_make_pipe(JanetHandle handles[2], int mode) { #ifdef JANET_WINDOWS /* * On windows, the built in CreatePipe function doesn't support overlapped IO * so we lift from the windows source code and modify for our own version. */ JanetHandle shandle, chandle; CHAR PipeNameBuffer[MAX_PATH]; SECURITY_ATTRIBUTES saAttr; memset(&saAttr, 0, sizeof(saAttr)); saAttr.nLength = sizeof(saAttr); saAttr.bInheritHandle = TRUE; if (mode == 3) { /* No overlapped IO involved, just call CreatePipe */ if (!CreatePipe(handles, handles + 1, &saAttr, 0)) return -1; return 0; } snprintf(PipeNameBuffer, sizeof(PipeNameBuffer), "\\\\.\\Pipe\\JanetPipeFile.%08x.%08x", (unsigned int) GetCurrentProcessId(), (unsigned int) InterlockedIncrement(&PipeSerialNumber)); /* server handle goes to subprocess */ shandle = CreateNamedPipeA( PipeNameBuffer, (mode == 2 ? PIPE_ACCESS_INBOUND : PIPE_ACCESS_OUTBOUND) | FILE_FLAG_OVERLAPPED, PIPE_TYPE_BYTE | PIPE_WAIT, 255, /* Max number of pipes for duplication. */ 4096, /* Out buffer size */ 4096, /* In buffer size */ 120 * 1000, /* Timeout in ms */ &saAttr); if (shandle == INVALID_HANDLE_VALUE) { return -1; } /* we keep client handle */ chandle = CreateFileA( PipeNameBuffer, (mode == 2 ? GENERIC_WRITE : GENERIC_READ), 0, &saAttr, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL | FILE_FLAG_OVERLAPPED, NULL); if (chandle == INVALID_HANDLE_VALUE) { CloseHandle(shandle); return -1; } if (mode == 2) { handles[0] = shandle; handles[1] = chandle; } else { handles[0] = chandle; handles[1] = shandle; } return 0; #else if (pipe(handles)) return -1; if (mode != 2 && fcntl(handles[0], F_SETFD, FD_CLOEXEC)) goto error; if (mode != 1 && fcntl(handles[1], F_SETFD, FD_CLOEXEC)) goto error; if (mode != 2 && mode != 3 && fcntl(handles[0], F_SETFL, O_NONBLOCK)) goto error; if (mode != 1 && mode != 3 && fcntl(handles[1], F_SETFL, O_NONBLOCK)) goto error; return 0; error: close(handles[0]); close(handles[1]); return -1; #endif } /* C functions */ JANET_CORE_FN(cfun_ev_go, "(ev/go fiber-or-fun &opt value supervisor)", "Put a fiber on the event loop to be resumed later. If a " "function is used, it is wrapped with `fiber/new` first. " "Returns a task fiber. Optionally pass a value to resume " "with, otherwise resumes with nil. An optional `core/channel` " "can be provided as a supervisor. When various events occur " "in the newly scheduled fiber, an event will be pushed to the " "supervisor. If not provided, the new fiber will inherit the " "current supervisor.") { janet_arity(argc, 1, 3); Janet value = argc >= 2 ? argv[1] : janet_wrap_nil(); void *supervisor = janet_optabstract(argv, argc, 2, &janet_channel_type, janet_vm.root_fiber->supervisor_channel); JanetFiber *fiber; if (janet_checktype(argv[0], JANET_FUNCTION)) { /* Create a fiber for the user */ JanetFunction *func = janet_unwrap_function(argv[0]); if (func->def->min_arity > 1) { janet_panicf("task function must accept 0 or 1 arguments"); } fiber = janet_fiber(func, 64, func->def->min_arity, &value); fiber->flags |= JANET_FIBER_MASK_ERROR | JANET_FIBER_MASK_USER0 | JANET_FIBER_MASK_USER1 | JANET_FIBER_MASK_USER2 | JANET_FIBER_MASK_USER3 | JANET_FIBER_MASK_USER4; if (!janet_vm.fiber->env) { janet_vm.fiber->env = janet_table(0); } fiber->env = janet_table(0); fiber->env->proto = janet_vm.fiber->env; } else { fiber = janet_getfiber(argv, 0); if (janet_fiber_status(fiber) != JANET_STATUS_NEW) { janet_panic("can only schedule new fibers where (= (fiber/status f) :new)"); } } fiber->supervisor_channel = supervisor; janet_schedule(fiber, value); return janet_wrap_fiber(fiber); } #define JANET_THREAD_SUPERVISOR_FLAG 0x100 /* For ev/thread - Run an interpreter in the new thread. */ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) { JanetBuffer *buffer = (JanetBuffer *) args.argp; const uint8_t *nextbytes = buffer->data; const uint8_t *endbytes = nextbytes + buffer->count; uint32_t flags = args.tag; args.tag = 0; janet_init(); janet_vm.sandbox_flags = (uint32_t) args.argi; JanetTryState tstate; JanetSignal signal = janet_try(&tstate); if (!signal) { /* Set abstract registry */ if (!(flags & 0x2)) { Janet aregv = janet_unmarshal(nextbytes, endbytes - nextbytes, JANET_MARSHAL_UNSAFE, NULL, &nextbytes); if (!janet_checktype(aregv, JANET_TABLE)) janet_panic("expected table for abstract registry"); janet_vm.abstract_registry = janet_unwrap_table(aregv); janet_gcroot(janet_wrap_table(janet_vm.abstract_registry)); } /* Get supervisor */ if (flags & JANET_THREAD_SUPERVISOR_FLAG) { Janet sup = janet_unmarshal(nextbytes, endbytes - nextbytes, JANET_MARSHAL_UNSAFE, NULL, &nextbytes); /* Hack - use a global variable to avoid longjmp clobber */ janet_vm.user = janet_unwrap_pointer(sup); } /* Set cfunction registry */ if (!(flags & 0x4)) { uint32_t count1; memcpy(&count1, nextbytes, sizeof(count1)); size_t count = (size_t) count1; /* Use division to avoid overflowing size_t */ if (count > (endbytes - nextbytes - sizeof(count1)) / sizeof(JanetCFunRegistry)) { janet_panic("thread message invalid"); } janet_vm.registry_count = count; janet_vm.registry_cap = count; janet_vm.registry = janet_malloc(count * sizeof(JanetCFunRegistry)); if (janet_vm.registry == NULL) { JANET_OUT_OF_MEMORY; } janet_vm.registry_dirty = 1; nextbytes += sizeof(uint32_t); memcpy(janet_vm.registry, nextbytes, count * sizeof(JanetCFunRegistry)); nextbytes += count * sizeof(JanetCFunRegistry); } Janet fiberv = janet_unmarshal(nextbytes, endbytes - nextbytes, JANET_MARSHAL_UNSAFE, NULL, &nextbytes); Janet value = janet_unmarshal(nextbytes, endbytes - nextbytes, JANET_MARSHAL_UNSAFE, NULL, &nextbytes); JanetFiber *fiber; if (!janet_checktype(fiberv, JANET_FIBER)) { if (!janet_checktype(fiberv, JANET_FUNCTION)) { janet_panicf("expected function or fiber, got %v", fiberv); } JanetFunction *func = janet_unwrap_function(fiberv); fiber = janet_fiber(func, 64, func->def->min_arity, &value); if (fiber == NULL) { janet_panicf("thread function must accept 0 or 1 arguments"); } fiber->flags |= JANET_FIBER_MASK_ERROR | JANET_FIBER_MASK_USER0 | JANET_FIBER_MASK_USER1 | JANET_FIBER_MASK_USER2 | JANET_FIBER_MASK_USER3 | JANET_FIBER_MASK_USER4; } else { fiber = janet_unwrap_fiber(fiberv); } if (flags & 0x8) { if (NULL == fiber->env) fiber->env = janet_table(0); janet_table_put(fiber->env, janet_ckeywordv("task-id"), value); } fiber->supervisor_channel = janet_vm.user; janet_schedule(fiber, value); janet_loop(); args.tag = JANET_EV_TCTAG_NIL; } else { void *supervisor = janet_vm.user; if (NULL != supervisor) { /* Got a supervisor, write error there */ Janet pair[] = { janet_ckeywordv("error"), tstate.payload }; janet_channel_push((JanetChannel *)supervisor, janet_wrap_tuple(janet_tuple_n(pair, 2)), 2); } else if (flags & 0x1) { /* No wait, just print to stderr */ janet_eprintf("thread start failure: %v\n", tstate.payload); } else { /* Make ev/thread call from parent thread error */ if (janet_checktype(tstate.payload, JANET_STRING)) { args.tag = JANET_EV_TCTAG_ERR_STRINGF; args.argp = strdup((const char *) janet_unwrap_string(tstate.payload)); } else { args.tag = JANET_EV_TCTAG_ERR_STRING; args.argp = "failed to start thread"; } } } janet_restore(&tstate); janet_buffer_deinit(buffer); janet_free(buffer); janet_deinit(); return args; } JANET_CORE_FN(cfun_ev_thread, "(ev/thread main &opt value flags supervisor)", "Run `main` in a new operating system thread, optionally passing `value` " "to resume with. The parameter `main` can either be a fiber, or a function that accepts " "0 or 1 arguments. " "Unlike `ev/go`, this function will suspend the current fiber until the thread is complete. " "If you want to run the thread without waiting for a result, pass the `:n` flag to return nil immediately. " "Otherwise, returns nil. Available flags:\n\n" "* `:n` - return immediately\n" "* `:t` - set the task-id of the new thread to value. The task-id is passed in messages to the supervisor channel.\n" "* `:a` - don't copy abstract registry to new thread (performance optimization)\n" "* `:c` - don't copy cfunction registry to new thread (performance optimization)") { janet_sandbox_assert(JANET_SANDBOX_THREADS); janet_arity(argc, 1, 4); Janet value = argc >= 2 ? argv[1] : janet_wrap_nil(); if (!janet_checktype(argv[0], JANET_FUNCTION)) janet_getfiber(argv, 0); uint64_t flags = 0; if (argc >= 3) { flags = janet_getflags(argv, 2, "nact"); } void *supervisor = janet_optabstract(argv, argc, 3, &janet_channel_type, janet_vm.root_fiber->supervisor_channel); if (NULL != supervisor) flags |= JANET_THREAD_SUPERVISOR_FLAG; /* Marshal arguments for the new thread. */ JanetBuffer *buffer = janet_malloc(sizeof(JanetBuffer)); if (NULL == buffer) { JANET_OUT_OF_MEMORY; } janet_buffer_init(buffer, 0); if (!(flags & 0x2)) { janet_marshal(buffer, janet_wrap_table(janet_vm.abstract_registry), NULL, JANET_MARSHAL_UNSAFE); } if (flags & JANET_THREAD_SUPERVISOR_FLAG) { janet_marshal(buffer, janet_wrap_abstract(supervisor), NULL, JANET_MARSHAL_UNSAFE); } if (!(flags & 0x4)) { janet_assert(janet_vm.registry_count <= INT32_MAX, "assert failed size check"); uint32_t temp = (uint32_t) janet_vm.registry_count; janet_buffer_push_bytes(buffer, (uint8_t *) &temp, sizeof(temp)); janet_buffer_push_bytes(buffer, (uint8_t *) janet_vm.registry, (int32_t) janet_vm.registry_count * sizeof(JanetCFunRegistry)); } janet_marshal(buffer, argv[0], NULL, JANET_MARSHAL_UNSAFE); janet_marshal(buffer, value, NULL, JANET_MARSHAL_UNSAFE); if (flags & 0x1) { /* Return immediately */ JanetEVGenericMessage arguments; memset(&arguments, 0, sizeof(arguments)); arguments.tag = (uint32_t) flags; arguments.argi = (uint32_t) janet_vm.sandbox_flags; arguments.argp = buffer; arguments.fiber = NULL; janet_ev_threaded_call(janet_go_thread_subr, arguments, janet_ev_default_threaded_callback); return janet_wrap_nil(); } else { janet_ev_threaded_await(janet_go_thread_subr, (uint32_t) flags, (uint32_t) janet_vm.sandbox_flags, buffer); } } JANET_CORE_FN(cfun_ev_give_supervisor, "(ev/give-supervisor tag & payload)", "Send a message to the current supervisor channel if there is one. The message will be a " "tuple of all of the arguments combined into a single message, where the first element is tag. " "By convention, tag should be a keyword indicating the type of message. Returns nil.") { janet_arity(argc, 1, -1); void *chanv = janet_vm.root_fiber->supervisor_channel; if (NULL != chanv) { JanetChannel *chan = janet_channel_unwrap(chanv); if (janet_channel_push(chan, janet_wrap_tuple(janet_tuple_n(argv, argc)), 0)) { janet_await(); } } return janet_wrap_nil(); } JANET_NO_RETURN void janet_sleep_await(double sec) { JanetTimeout to; to.when = ts_delta(ts_now(), sec); to.fiber = janet_vm.root_fiber; to.is_error = 0; to.sched_id = to.fiber->sched_id; to.curr_fiber = NULL; to.has_worker = 0; add_timeout(to); janet_await(); } JANET_CORE_FN(cfun_ev_sleep, "(ev/sleep sec)", "Suspend the current fiber for sec seconds without blocking the event loop.") { janet_fixarity(argc, 1); double sec = janet_getnumber(argv, 0); janet_sleep_await(sec); } JANET_CORE_FN(cfun_ev_deadline, "(ev/deadline sec &opt tocancel tocheck intr?)", "Schedules the event loop to try to cancel the `tocancel` task as with `ev/cancel`. " "After `sec` seconds, the event loop will attempt cancellation of `tocancel` if the " "`tocheck` fiber is resumable. `sec` is a number that can have a fractional part. " "`tocancel` defaults to `(fiber/root)`, but if specified, must be a task (root " "fiber). `tocheck` defaults to `(fiber/current)`, but if specified, must be a fiber. " "Returns `tocancel` immediately. If `interrupt?` is set to true, will create a " "background thread to try to interrupt the VM if the timeout expires.") { janet_arity(argc, 1, 4); double sec = janet_getnumber(argv, 0); sec = (sec < 0) ? 0 : sec; JanetFiber *tocancel = janet_optfiber(argv, argc, 1, janet_vm.root_fiber); JanetFiber *tocheck = janet_optfiber(argv, argc, 2, janet_vm.fiber); int use_interrupt = janet_optboolean(argv, argc, 3, 0); JanetTimeout to; to.when = ts_delta(ts_now(), sec); to.fiber = tocancel; to.curr_fiber = tocheck; to.is_error = 0; to.sched_id = to.fiber->sched_id; if (use_interrupt) { #ifdef JANET_ANDROID janet_sandbox_assert(JANET_SANDBOX_SIGNAL); #endif JanetThreadedTimeout *tto = janet_malloc(sizeof(JanetThreadedTimeout)); if (NULL == tto) { JANET_OUT_OF_MEMORY; } tto->sec = sec; tto->vm = &janet_vm; tto->fiber = tocheck; #ifdef JANET_WINDOWS HANDLE cancel_event = CreateEvent(NULL, TRUE, FALSE, NULL); if (NULL == cancel_event) { janet_free(tto); janet_panic("failed to create cancel event"); } tto->cancel_event = cancel_event; HANDLE worker = CreateThread(NULL, 0, janet_timeout_body, tto, CREATE_SUSPENDED, NULL); if (NULL == worker) { janet_free(tto); janet_panic("failed to create thread"); } #else pthread_t worker; int err = pthread_create(&worker, NULL, janet_timeout_body, tto); if (err) { janet_free(tto); janet_panicf("%s", janet_strerror(err)); } #endif to.has_worker = 1; to.worker = worker; #ifdef JANET_WINDOWS to.worker_event = cancel_event; ResumeThread(worker); #endif } else { to.has_worker = 0; } add_timeout(to); return janet_wrap_fiber(tocancel); } JANET_CORE_FN(cfun_ev_cancel, "(ev/cancel fiber err)", "Cancel a suspended task fiber in the event loop. Differs from " "`cancel` in that it returns the canceled fiber immediately.") { janet_fixarity(argc, 2); JanetFiber *fiber = janet_getfiber(argv, 0); Janet err = argv[1]; janet_cancel(fiber, err); return argv[0]; } JANET_CORE_FN(janet_cfun_stream_close, "(ev/close stream)", "Close a stream. This should be the same as calling (:close stream) for all streams.") { janet_fixarity(argc, 1); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_close(stream); return argv[0]; } JANET_CORE_FN(janet_cfun_stream_read, "(ev/read stream n &opt buffer timeout)", "Read up to n bytes into a buffer asynchronously from a stream. `n` can also be the keyword " "`:all` to read into the buffer until end of stream. " "Optionally provide a buffer to write into " "as well as a timeout in seconds after which to cancel the operation and raise an error. " "Returns the buffer if the read was successful or nil if end-of-stream reached. Will raise an " "error if there are problems with the IO operation.") { janet_arity(argc, 2, 4); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_READABLE); JanetBuffer *buffer = janet_optbuffer(argv, argc, 2, 10); double to = janet_optnumber(argv, argc, 3, INFINITY); if (janet_keyeq(argv[1], "all")) { if (to != INFINITY) janet_addtimeout(to); janet_ev_readchunk(stream, buffer, INT32_MAX); } else { int32_t n = janet_getnat(argv, 1); if (to != INFINITY) janet_addtimeout(to); janet_ev_read(stream, buffer, n); } } JANET_CORE_FN(janet_cfun_stream_chunk, "(ev/chunk stream n &opt buffer timeout)", "Same as ev/read, but will not return early if less than n bytes are available. If an end of " "stream is reached, will also return early with the collected bytes.") { janet_arity(argc, 2, 4); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_READABLE); int32_t n = janet_getnat(argv, 1); JanetBuffer *buffer = janet_optbuffer(argv, argc, 2, 10); double to = janet_optnumber(argv, argc, 3, INFINITY); if (to != INFINITY) janet_addtimeout(to); janet_ev_readchunk(stream, buffer, n); } JANET_CORE_FN(janet_cfun_stream_write, "(ev/write stream data &opt timeout)", "Write data to a stream, suspending the current fiber until the write " "completes. Takes an optional timeout in seconds, after which will return nil. " "Returns nil, or raises an error if the write failed.") { janet_arity(argc, 2, 3); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_WRITABLE); double to = janet_optnumber(argv, argc, 2, INFINITY); if (janet_checktype(argv[1], JANET_BUFFER)) { if (to != INFINITY) janet_addtimeout(to); janet_ev_write_buffer(stream, janet_getbuffer(argv, 1)); } else { JanetByteView bytes = janet_getbytes(argv, 1); if (to != INFINITY) janet_addtimeout(to); janet_ev_write_string(stream, bytes.bytes); } } static int mutexgc(void *p, size_t size) { (void) size; janet_os_mutex_deinit(p); return 0; } const JanetAbstractType janet_mutex_type = { "core/lock", mutexgc, JANET_ATEND_GC }; JANET_CORE_FN(janet_cfun_mutex, "(ev/lock)", "Create a new lock to coordinate threads.") { janet_fixarity(argc, 0); (void) argv; void *mutex = janet_abstract_threaded(&janet_mutex_type, janet_os_mutex_size()); janet_os_mutex_init(mutex); return janet_wrap_abstract(mutex); } JANET_CORE_FN(janet_cfun_mutex_acquire, "(ev/acquire-lock lock)", "Acquire a lock such that this operating system thread is the only thread with access to this resource." " This will block this entire thread until the lock becomes available, and will not yield to other fibers " "on this system thread.") { janet_fixarity(argc, 1); void *mutex = janet_getabstract(argv, 0, &janet_mutex_type); janet_os_mutex_lock(mutex); return argv[0]; } JANET_CORE_FN(janet_cfun_mutex_release, "(ev/release-lock lock)", "Release a lock such that other threads may acquire it.") { janet_fixarity(argc, 1); void *mutex = janet_getabstract(argv, 0, &janet_mutex_type); janet_os_mutex_unlock(mutex); return argv[0]; } static int rwlockgc(void *p, size_t size) { (void) size; janet_os_rwlock_deinit(p); return 0; } const JanetAbstractType janet_rwlock_type = { "core/rwlock", rwlockgc, JANET_ATEND_GC }; JANET_CORE_FN(janet_cfun_rwlock, "(ev/rwlock)", "Create a new read-write lock to coordinate threads.") { janet_fixarity(argc, 0); (void) argv; void *rwlock = janet_abstract_threaded(&janet_rwlock_type, janet_os_rwlock_size()); janet_os_rwlock_init(rwlock); return janet_wrap_abstract(rwlock); } JANET_CORE_FN(janet_cfun_rwlock_read_lock, "(ev/acquire-rlock rwlock)", "Acquire a read lock an a read-write lock.") { janet_fixarity(argc, 1); void *rwlock = janet_getabstract(argv, 0, &janet_rwlock_type); janet_os_rwlock_rlock(rwlock); return argv[0]; } JANET_CORE_FN(janet_cfun_rwlock_write_lock, "(ev/acquire-wlock rwlock)", "Acquire a write lock on a read-write lock.") { janet_fixarity(argc, 1); void *rwlock = janet_getabstract(argv, 0, &janet_rwlock_type); janet_os_rwlock_wlock(rwlock); return argv[0]; } JANET_CORE_FN(janet_cfun_rwlock_read_release, "(ev/release-rlock rwlock)", "Release a read lock on a read-write lock") { janet_fixarity(argc, 1); void *rwlock = janet_getabstract(argv, 0, &janet_rwlock_type); janet_os_rwlock_runlock(rwlock); return argv[0]; } JANET_CORE_FN(janet_cfun_rwlock_write_release, "(ev/release-wlock rwlock)", "Release a write lock on a read-write lock") { janet_fixarity(argc, 1); void *rwlock = janet_getabstract(argv, 0, &janet_rwlock_type); janet_os_rwlock_wunlock(rwlock); return argv[0]; } static JanetFile *get_file_for_stream(JanetStream *stream) { int32_t flags = 0; char fmt[4] = {0}; int index = 0; if (stream->flags & JANET_STREAM_READABLE) { flags |= JANET_FILE_READ; janet_sandbox_assert(JANET_SANDBOX_FS_READ); fmt[index++] = 'r'; } if (stream->flags & JANET_STREAM_WRITABLE) { flags |= JANET_FILE_WRITE; janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); int currindex = index; fmt[index++] = (currindex == 0) ? 'w' : '+'; } if (index == 0) return NULL; /* duplicate handle when converting stream to file */ #ifdef JANET_WINDOWS int htype = 0; if (fmt[0] == 'r' && fmt[1] == '+') { htype = _O_RDWR; } else if (fmt[0] == 'r') { htype = _O_RDONLY; } else if (fmt[0] == 'w') { htype = _O_WRONLY; } int fd = _open_osfhandle((intptr_t) stream->handle, htype); if (fd < 0) return NULL; int fd_dup = _dup(fd); if (fd_dup < 0) return NULL; FILE *f = _fdopen(fd_dup, fmt); if (NULL == f) { _close(fd_dup); return NULL; } #else int fd_dup = dup(stream->handle); if (fd_dup < 0) return NULL; FILE *f = fdopen(fd_dup, fmt); if (NULL == f) { close(fd_dup); return NULL; } #endif return janet_makejfile(f, flags); } JANET_CORE_FN(janet_cfun_to_file, "(ev/to-file)", "Create core/file copy of the stream. This value can be used " "when blocking IO behavior is needed.") { janet_fixarity(argc, 1); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); JanetFile *iof = get_file_for_stream(stream); if (iof == NULL) janet_panic("cannot make file from stream"); return janet_wrap_abstract(iof); } JANET_CORE_FN(janet_cfun_ev_all_tasks, "(ev/all-tasks)", "Get an array of all active task fibers that are being used by the scheduler.") { janet_fixarity(argc, 0); (void) argv; JanetArray *array = janet_array(janet_vm.active_tasks.count); for (int32_t i = 0; i < janet_vm.active_tasks.capacity; i++) { if (!janet_checktype(janet_vm.active_tasks.data[i].key, JANET_NIL)) { janet_array_push(array, janet_vm.active_tasks.data[i].key); } } return janet_wrap_array(array); } void janet_lib_ev(JanetTable *env) { JanetRegExt ev_cfuns_ext[] = { JANET_CORE_REG("ev/give", cfun_channel_push), JANET_CORE_REG("ev/take", cfun_channel_pop), JANET_CORE_REG("ev/full", cfun_channel_full), JANET_CORE_REG("ev/capacity", cfun_channel_capacity), JANET_CORE_REG("ev/count", cfun_channel_count), JANET_CORE_REG("ev/select", cfun_channel_choice), JANET_CORE_REG("ev/rselect", cfun_channel_rchoice), JANET_CORE_REG("ev/chan", cfun_channel_new), JANET_CORE_REG("ev/thread-chan", cfun_channel_new_threaded), JANET_CORE_REG("ev/chan-close", cfun_channel_close), JANET_CORE_REG("ev/go", cfun_ev_go), JANET_CORE_REG("ev/thread", cfun_ev_thread), JANET_CORE_REG("ev/give-supervisor", cfun_ev_give_supervisor), JANET_CORE_REG("ev/sleep", cfun_ev_sleep), JANET_CORE_REG("ev/deadline", cfun_ev_deadline), JANET_CORE_REG("ev/cancel", cfun_ev_cancel), JANET_CORE_REG("ev/close", janet_cfun_stream_close), JANET_CORE_REG("ev/read", janet_cfun_stream_read), JANET_CORE_REG("ev/chunk", janet_cfun_stream_chunk), JANET_CORE_REG("ev/write", janet_cfun_stream_write), JANET_CORE_REG("ev/lock", janet_cfun_mutex), JANET_CORE_REG("ev/acquire-lock", janet_cfun_mutex_acquire), JANET_CORE_REG("ev/release-lock", janet_cfun_mutex_release), JANET_CORE_REG("ev/rwlock", janet_cfun_rwlock), JANET_CORE_REG("ev/acquire-rlock", janet_cfun_rwlock_read_lock), JANET_CORE_REG("ev/acquire-wlock", janet_cfun_rwlock_write_lock), JANET_CORE_REG("ev/release-rlock", janet_cfun_rwlock_read_release), JANET_CORE_REG("ev/release-wlock", janet_cfun_rwlock_write_release), JANET_CORE_REG("ev/to-file", janet_cfun_to_file), JANET_CORE_REG("ev/all-tasks", janet_cfun_ev_all_tasks), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, ev_cfuns_ext); janet_register_abstract_type(&janet_stream_type); janet_register_abstract_type(&janet_channel_type); janet_register_abstract_type(&janet_mutex_type); janet_register_abstract_type(&janet_rwlock_type); } #endif janet-1.41.2/src/core/features.h000066400000000000000000000047411514534607600164270ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ /* Feature test macros */ #ifndef JANET_FEATURES_H_defined #define JANET_FEATURES_H_defined #if defined(__NetBSD__) || defined(__APPLE__) || defined(__OpenBSD__) \ || defined(__bsdi__) || defined(__DragonFly__) || defined(__FreeBSD__) /* Use BSD source on any BSD systems, include OSX */ # define _BSD_SOURCE # define _POSIX_C_SOURCE 200809L #else /* Use POSIX feature flags */ # ifndef _POSIX_C_SOURCE # define _POSIX_C_SOURCE 200809L # endif #endif #if defined(__APPLE__) #define _DARWIN_C_SOURCE #endif /* Needed for sched.h for cpu count */ #ifdef __linux__ #define _GNU_SOURCE #endif #if defined(WIN32) || defined(_WIN32) #define WIN32_LEAN_AND_MEAN #endif /* needed for inet_pton and InitializeSRWLock */ #ifdef __MINGW32__ #define _WIN32_WINNT _WIN32_WINNT_VISTA #endif /* Needed for realpath on linux, as well as pthread rwlocks. */ #ifndef _XOPEN_SOURCE #define _XOPEN_SOURCE 600 #endif #if _XOPEN_SOURCE < 600 #undef _XOPEN_SOURCE #define _XOPEN_SOURCE 600 #endif /* Needed for timegm and other extensions when building with -std=c99. * It also defines realpath, etc, which would normally require * _XOPEN_SOURCE >= 500. */ #if !defined(_NETBSD_SOURCE) && defined(__NetBSD__) #define _NETBSD_SOURCE #endif /* Needed for several things when building with -std=c99. */ #if !__BSD_VISIBLE && (defined(__DragonFly__) || defined(__FreeBSD__)) #define __BSD_VISIBLE 1 #endif #define _FILE_OFFSET_BITS 64 #endif janet-1.41.2/src/core/ffi.c000066400000000000000000002333531514534607600153530ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "util.h" #include "gc.h" #endif #ifdef JANET_FFI #ifdef _MSC_VER #define alloca _alloca #elif defined(JANET_LINUX) #include #elif !defined(alloca) /* Last ditch effort to get alloca - works for gcc and clang */ #define alloca __builtin_alloca #endif /* FFI jit includes */ #ifdef JANET_FFI_JIT #ifndef JANET_WINDOWS #include #endif #endif #define JANET_FFI_MAX_RECUR 64 /* Compiler, OS, and arch detection. Used * to enable a set of calling conventions. The * :none calling convention is always enabled. */ #if defined(JANET_WINDOWS) && (defined(__x86_64__) || defined(_M_X64)) #define JANET_FFI_WIN64_ENABLED #endif #if (defined(__x86_64__) || defined(_M_X64)) && !defined(JANET_WINDOWS) #define JANET_FFI_SYSV64_ENABLED #endif #if (defined(__aarch64__) || defined(_M_ARM64)) && !defined(JANET_WINDOWS) #define JANET_FFI_AAPCS64_ENABLED #endif typedef struct JanetFFIType JanetFFIType; typedef struct JanetFFIStruct JanetFFIStruct; typedef enum { JANET_FFI_TYPE_VOID, JANET_FFI_TYPE_BOOL, JANET_FFI_TYPE_PTR, JANET_FFI_TYPE_STRING, JANET_FFI_TYPE_FLOAT, JANET_FFI_TYPE_DOUBLE, JANET_FFI_TYPE_INT8, JANET_FFI_TYPE_UINT8, JANET_FFI_TYPE_INT16, JANET_FFI_TYPE_UINT16, JANET_FFI_TYPE_INT32, JANET_FFI_TYPE_UINT32, JANET_FFI_TYPE_INT64, JANET_FFI_TYPE_UINT64, JANET_FFI_TYPE_STRUCT } JanetFFIPrimType; /* Custom alignof since alignof not in c99 standard */ #define ALIGNOF(type) offsetof(struct { char c; type member; }, member) typedef struct { size_t size; size_t align; } JanetFFIPrimInfo; static const JanetFFIPrimInfo janet_ffi_type_info[] = { {0, 0}, /* JANET_FFI_TYPE_VOID */ {sizeof(char), ALIGNOF(char)}, /* JANET_FFI_TYPE_BOOL */ {sizeof(void *), ALIGNOF(void *)}, /* JANET_FFI_TYPE_PTR */ {sizeof(char *), ALIGNOF(char *)}, /* JANET_FFI_TYPE_STRING */ {sizeof(float), ALIGNOF(float)}, /* JANET_FFI_TYPE_FLOAT */ {sizeof(double), ALIGNOF(double)}, /* JANET_FFI_TYPE_DOUBLE */ {sizeof(int8_t), ALIGNOF(int8_t)}, /* JANET_FFI_TYPE_INT8 */ {sizeof(uint8_t), ALIGNOF(uint8_t)}, /* JANET_FFI_TYPE_UINT8 */ {sizeof(int16_t), ALIGNOF(int16_t)}, /* JANET_FFI_TYPE_INT16 */ {sizeof(uint16_t), ALIGNOF(uint16_t)}, /* JANET_FFI_TYPE_UINT16 */ {sizeof(int32_t), ALIGNOF(int32_t)}, /* JANET_FFI_TYPE_INT32 */ {sizeof(uint32_t), ALIGNOF(uint32_t)}, /* JANET_FFI_TYPE_UINT32 */ {sizeof(int64_t), ALIGNOF(int64_t)}, /* JANET_FFI_TYPE_INT64 */ {sizeof(uint64_t), ALIGNOF(uint64_t)}, /* JANET_FFI_TYPE_UINT64 */ {0, ALIGNOF(uint64_t)} /* JANET_FFI_TYPE_STRUCT */ }; struct JanetFFIType { JanetFFIStruct *st; JanetFFIPrimType prim; int32_t array_count; }; typedef struct { JanetFFIType type; size_t offset; } JanetFFIStructMember; /* Also used to store array types */ struct JanetFFIStruct { uint32_t size; uint32_t align; uint32_t field_count; uint32_t is_aligned; JanetFFIStructMember fields[]; }; /* Specifies how the registers are classified. This is used * to determine if a certain argument should be passed in a register, * on the stack, special floating pointer register, etc. */ typedef enum { JANET_SYSV64_INTEGER, JANET_SYSV64_SSE, JANET_SYSV64_SSEUP, JANET_SYSV64_PAIR_INTINT, JANET_SYSV64_PAIR_INTSSE, JANET_SYSV64_PAIR_SSEINT, JANET_SYSV64_PAIR_SSESSE, JANET_SYSV64_NO_CLASS, JANET_SYSV64_MEMORY, JANET_WIN64_REGISTER, JANET_WIN64_STACK, JANET_WIN64_REGISTER_REF, JANET_WIN64_STACK_REF, JANET_AAPCS64_GENERAL, JANET_AAPCS64_SSE, JANET_AAPCS64_GENERAL_REF, JANET_AAPCS64_STACK, JANET_AAPCS64_STACK_REF, JANET_AAPCS64_NONE } JanetFFIWordSpec; /* Describe how each Janet argument is interpreted in terms of machine words * that will be mapped to registers/stack. */ typedef struct { JanetFFIType type; JanetFFIWordSpec spec; uint32_t offset; /* point to the exact register / stack offset depending on spec. */ uint32_t offset2; /* for reference passing apis (windows), use to allocate reference */ } JanetFFIMapping; typedef enum { JANET_FFI_CC_NONE, JANET_FFI_CC_SYSV_64, JANET_FFI_CC_WIN_64, JANET_FFI_CC_AAPCS64 } JanetFFICallingConvention; #ifdef JANET_FFI_WIN64_ENABLED #define JANET_FFI_CC_DEFAULT JANET_FFI_CC_WIN_64 #elif defined(JANET_FFI_SYSV64_ENABLED) #define JANET_FFI_CC_DEFAULT JANET_FFI_CC_SYSV_64 #elif defined(JANET_FFI_AAPCS64_ENABLED) #define JANET_FFI_CC_DEFAULT JANET_FFI_CC_AAPCS64 #else #define JANET_FFI_CC_DEFAULT JANET_FFI_CC_NONE #endif #define JANET_FFI_MAX_ARGS 32 typedef struct { uint32_t frame_size; uint32_t arg_count; uint32_t word_count; uint32_t variant; uint32_t stack_count; JanetFFICallingConvention cc; JanetFFIMapping ret; JanetFFIMapping args[JANET_FFI_MAX_ARGS]; } JanetFFISignature; int signature_mark(void *p, size_t s) { (void) s; JanetFFISignature *sig = p; for (uint32_t i = 0; i < sig->arg_count; i++) { JanetFFIType t = sig->args[i].type; if (t.prim == JANET_FFI_TYPE_STRUCT) { janet_mark(janet_wrap_abstract(t.st)); } } return 0; } static const JanetAbstractType janet_signature_type = { "core/ffi-signature", NULL, signature_mark, JANET_ATEND_GCMARK }; int struct_mark(void *p, size_t s) { (void) s; JanetFFIStruct *st = p; for (uint32_t i = 0; i < st->field_count; i++) { JanetFFIType t = st->fields[i].type; if (t.prim == JANET_FFI_TYPE_STRUCT) { janet_mark(janet_wrap_abstract(t.st)); } } return 0; } typedef struct { void *function_pointer; size_t size; } JanetFFIJittedFn; static const JanetAbstractType janet_struct_type = { "core/ffi-struct", NULL, struct_mark, JANET_ATEND_GCMARK }; static int janet_ffijit_gc(void *p, size_t s) { (void) s; JanetFFIJittedFn *fn = p; if (fn->function_pointer == NULL) return 0; #ifdef JANET_FFI_JIT #ifdef JANET_WINDOWS VirtualFree(fn->function_pointer, fn->size, MEM_RELEASE); #else munmap(fn->function_pointer, fn->size); #endif #endif return 0; } static JanetByteView janet_ffijit_getbytes(void *p, size_t s) { (void) s; JanetFFIJittedFn *fn = p; JanetByteView bytes; bytes.bytes = fn->function_pointer; bytes.len = (int32_t) fn->size; return bytes; } static size_t janet_ffijit_length(void *p, size_t s) { (void) s; JanetFFIJittedFn *fn = p; return fn->size; } const JanetAbstractType janet_type_ffijit = { .name = "ffi/jitfn", .gc = janet_ffijit_gc, .bytes = janet_ffijit_getbytes, .length = janet_ffijit_length }; typedef struct { Clib clib; int closed; int is_self; } JanetAbstractNative; static const JanetAbstractType janet_native_type = { "core/ffi-native", JANET_ATEND_NAME }; static JanetFFIType prim_type(JanetFFIPrimType pt) { JanetFFIType t; t.prim = pt; t.st = NULL; t.array_count = -1; return t; } static size_t type_size(JanetFFIType t) { size_t count = t.array_count < 0 ? 1 : (size_t) t.array_count; if (t.prim == JANET_FFI_TYPE_STRUCT) { return t.st->size * count; } else { return janet_ffi_type_info[t.prim].size * count; } } static size_t type_align(JanetFFIType t) { if (t.prim == JANET_FFI_TYPE_STRUCT) { return t.st->align; } else { return janet_ffi_type_info[t.prim].align; } } static JanetFFICallingConvention decode_ffi_cc(const uint8_t *name) { if (!janet_cstrcmp(name, "none")) return JANET_FFI_CC_NONE; #ifdef JANET_FFI_WIN64_ENABLED if (!janet_cstrcmp(name, "win64")) return JANET_FFI_CC_WIN_64; #endif #ifdef JANET_FFI_SYSV64_ENABLED if (!janet_cstrcmp(name, "sysv64")) return JANET_FFI_CC_SYSV_64; #endif #ifdef JANET_FFI_AAPCS64_ENABLED if (!janet_cstrcmp(name, "aapcs64")) return JANET_FFI_CC_AAPCS64; #endif if (!janet_cstrcmp(name, "default")) return JANET_FFI_CC_DEFAULT; janet_panicf("unknown calling convention %s", name); } static JanetFFIPrimType decode_ffi_prim(const uint8_t *name) { if (!janet_cstrcmp(name, "void")) return JANET_FFI_TYPE_VOID; if (!janet_cstrcmp(name, "bool")) return JANET_FFI_TYPE_BOOL; if (!janet_cstrcmp(name, "ptr")) return JANET_FFI_TYPE_PTR; if (!janet_cstrcmp(name, "pointer")) return JANET_FFI_TYPE_PTR; if (!janet_cstrcmp(name, "string")) return JANET_FFI_TYPE_STRING; if (!janet_cstrcmp(name, "float")) return JANET_FFI_TYPE_FLOAT; if (!janet_cstrcmp(name, "double")) return JANET_FFI_TYPE_DOUBLE; if (!janet_cstrcmp(name, "int8")) return JANET_FFI_TYPE_INT8; if (!janet_cstrcmp(name, "uint8")) return JANET_FFI_TYPE_UINT8; if (!janet_cstrcmp(name, "int16")) return JANET_FFI_TYPE_INT16; if (!janet_cstrcmp(name, "uint16")) return JANET_FFI_TYPE_UINT16; if (!janet_cstrcmp(name, "int32")) return JANET_FFI_TYPE_INT32; if (!janet_cstrcmp(name, "uint32")) return JANET_FFI_TYPE_UINT32; if (!janet_cstrcmp(name, "int64")) return JANET_FFI_TYPE_INT64; if (!janet_cstrcmp(name, "uint64")) return JANET_FFI_TYPE_UINT64; #ifdef JANET_64 if (!janet_cstrcmp(name, "size")) return JANET_FFI_TYPE_UINT64; if (!janet_cstrcmp(name, "ssize")) return JANET_FFI_TYPE_INT64; #else if (!janet_cstrcmp(name, "size")) return JANET_FFI_TYPE_UINT32; if (!janet_cstrcmp(name, "ssize")) return JANET_FFI_TYPE_INT32; #endif /* aliases */ if (!janet_cstrcmp(name, "r32")) return JANET_FFI_TYPE_FLOAT; if (!janet_cstrcmp(name, "r64")) return JANET_FFI_TYPE_DOUBLE; if (!janet_cstrcmp(name, "s8")) return JANET_FFI_TYPE_INT8; if (!janet_cstrcmp(name, "u8")) return JANET_FFI_TYPE_UINT8; if (!janet_cstrcmp(name, "s16")) return JANET_FFI_TYPE_INT16; if (!janet_cstrcmp(name, "u16")) return JANET_FFI_TYPE_UINT16; if (!janet_cstrcmp(name, "s32")) return JANET_FFI_TYPE_INT32; if (!janet_cstrcmp(name, "u32")) return JANET_FFI_TYPE_UINT32; if (!janet_cstrcmp(name, "s64")) return JANET_FFI_TYPE_INT64; if (!janet_cstrcmp(name, "u64")) return JANET_FFI_TYPE_UINT64; if (!janet_cstrcmp(name, "char")) return JANET_FFI_TYPE_INT8; if (!janet_cstrcmp(name, "short")) return JANET_FFI_TYPE_INT16; if (!janet_cstrcmp(name, "int")) return JANET_FFI_TYPE_INT32; if (!janet_cstrcmp(name, "long")) return JANET_FFI_TYPE_INT64; if (!janet_cstrcmp(name, "byte")) return JANET_FFI_TYPE_UINT8; if (!janet_cstrcmp(name, "uchar")) return JANET_FFI_TYPE_UINT8; if (!janet_cstrcmp(name, "ushort")) return JANET_FFI_TYPE_UINT16; if (!janet_cstrcmp(name, "uint")) return JANET_FFI_TYPE_UINT32; if (!janet_cstrcmp(name, "ulong")) return JANET_FFI_TYPE_UINT64; janet_panicf("unknown machine type %s", name); } /* A common callback function signature. To avoid runtime code generation, which is prohibited * on many platforms, often buggy (see libffi), and generally complicated, instead provide * a single (or small set of commonly used function signatures). All callbacks should * eventually call this. */ void janet_ffi_trampoline(void *ctx, void *userdata) { if (NULL == userdata) { /* Userdata not set. */ janet_eprintf("no userdata found for janet callback"); return; } Janet context = janet_wrap_pointer(ctx); JanetFunction *fun = userdata; janet_call(fun, 1, &context); } static JanetFFIType decode_ffi_type(Janet x); static JanetFFIStruct *build_struct_type(int32_t argc, const Janet *argv) { /* Use :pack to indicate a single packed struct member and :pack-all * to pack the remaining members */ int32_t member_count = argc; int all_packed = 0; for (int32_t i = 0; i < argc; i++) { if (janet_keyeq(argv[i], "pack")) { member_count--; } else if (janet_keyeq(argv[i], "pack-all")) { member_count--; all_packed = 1; } } JanetFFIStruct *st = janet_abstract(&janet_struct_type, sizeof(JanetFFIStruct) + argc * sizeof(JanetFFIStructMember)); st->field_count = 0; st->size = 0; st->align = 1; if (argc == 0) { janet_panic("invalid empty struct"); } uint32_t is_aligned = 1; int32_t i = 0; for (int32_t j = 0; j < argc; j++) { int pack_one = 0; if (janet_keyeq(argv[j], "pack") || janet_keyeq(argv[j], "pack-all")) { pack_one = 1; j++; if (j == argc) break; } st->fields[i].type = decode_ffi_type(argv[j]); size_t el_size = type_size(st->fields[i].type); size_t el_align = type_align(st->fields[i].type); if (el_align <= 0) janet_panicf("bad field type %V", argv[j]); if (all_packed || pack_one) { if (st->size % el_align != 0) is_aligned = 0; st->fields[i].offset = st->size; st->size += (uint32_t) el_size; } else { if (el_align > st->align) st->align = (uint32_t) el_align; st->fields[i].offset = (uint32_t)(((st->size + el_align - 1) / el_align) * el_align); st->size = (uint32_t)(el_size + st->fields[i].offset); } i++; } st->is_aligned = is_aligned; st->size += (st->align - 1); st->size /= st->align; st->size *= st->align; st->field_count = member_count; return st; } static JanetFFIType decode_ffi_type(Janet x) { if (janet_checktype(x, JANET_KEYWORD)) { return prim_type(decode_ffi_prim(janet_unwrap_keyword(x))); } JanetFFIType ret; ret.array_count = -1; ret.prim = JANET_FFI_TYPE_STRUCT; if (janet_checkabstract(x, &janet_struct_type)) { ret.st = janet_unwrap_abstract(x); return ret; } int32_t len; const Janet *els; if (janet_indexed_view(x, &els, &len)) { if (janet_checktype(x, JANET_ARRAY)) { if (len != 2 && len != 1) janet_panicf("array type must be of form @[type count], got %v", x); ret = decode_ffi_type(els[0]); int32_t array_count = len == 1 ? 0 : janet_getnat(els, 1); ret.array_count = array_count; } else { ret.st = build_struct_type(len, els); } return ret; } else { janet_panicf("bad native type %v", x); } } JANET_CORE_FN(cfun_ffi_struct, "(ffi/struct & types)", "Create a struct type definition that can be used to pass structs into native functions. ") { janet_arity(argc, 1, -1); return janet_wrap_abstract(build_struct_type(argc, argv)); } JANET_CORE_FN(cfun_ffi_size, "(ffi/size type)", "Get the size of an ffi type in bytes.") { janet_fixarity(argc, 1); size_t size = type_size(decode_ffi_type(argv[0])); return janet_wrap_number((double) size); } JANET_CORE_FN(cfun_ffi_align, "(ffi/align type)", "Get the align of an ffi type in bytes.") { janet_fixarity(argc, 1); size_t size = type_align(decode_ffi_type(argv[0])); return janet_wrap_number((double) size); } static void *janet_ffi_getpointer(const Janet *argv, int32_t n) { switch (janet_type(argv[n])) { default: janet_panicf("bad slot #%d, expected ffi pointer convertible type, got %v", n, argv[n]); case JANET_POINTER: case JANET_STRING: case JANET_KEYWORD: case JANET_SYMBOL: case JANET_CFUNCTION: return janet_unwrap_pointer(argv[n]); case JANET_ABSTRACT: return (void *) janet_getbytes(argv, n).bytes; case JANET_BUFFER: return janet_unwrap_buffer(argv[n])->data; case JANET_FUNCTION: /* Users may pass in a function. Any function passed is almost certainly * being used as a callback, so we add it to the root set. */ janet_gcroot(argv[n]); return janet_unwrap_pointer(argv[n]); case JANET_NIL: return NULL; } } static void *janet_ffi_get_callable_pointer(const Janet *argv, int32_t n) { switch (janet_type(argv[n])) { default: break; case JANET_POINTER: return janet_unwrap_pointer(argv[n]); case JANET_ABSTRACT: if (!janet_checkabstract(argv[n], &janet_type_ffijit)) break; return ((JanetFFIJittedFn *)janet_unwrap_abstract(argv[n]))->function_pointer; } janet_panicf("bad slot #%d, expected ffi callable pointer type, got %v", n, argv[n]); } /* Write a value given by some Janet values and an FFI type as it would appear in memory. * The alignment and space available is assumed to already be sufficient */ static void janet_ffi_write_one(void *to, const Janet *argv, int32_t n, JanetFFIType type, int recur) { if (recur == 0) janet_panic("recursion too deep"); if (type.array_count >= 0) { JanetFFIType el_type = type; el_type.array_count = -1; size_t el_size = type_size(el_type); JanetView els = janet_getindexed(argv, n); if (els.len != type.array_count) { janet_panicf("bad array length, expected %d, got %d", type.array_count, els.len); } char *cursor = to; for (int32_t i = 0; i < els.len; i++) { janet_ffi_write_one(cursor, els.items, i, el_type, recur - 1); cursor += el_size; } return; } switch (type.prim) { case JANET_FFI_TYPE_VOID: if (!janet_checktype(argv[n], JANET_NIL)) { janet_panicf("expected nil, got %v", argv[n]); } break; case JANET_FFI_TYPE_STRUCT: { JanetView els = janet_getindexed(argv, n); JanetFFIStruct *st = type.st; if ((uint32_t) els.len != st->field_count) { janet_panicf("wrong number of fields in struct, expected %d, got %d", (int32_t) st->field_count, els.len); } for (int32_t i = 0; i < els.len; i++) { JanetFFIType tp = st->fields[i].type; janet_ffi_write_one((char *) to + st->fields[i].offset, els.items, i, tp, recur - 1); } } break; case JANET_FFI_TYPE_DOUBLE: ((double *)(to))[0] = janet_getnumber(argv, n); break; case JANET_FFI_TYPE_FLOAT: ((float *)(to))[0] = (float) janet_getnumber(argv, n); break; case JANET_FFI_TYPE_PTR: ((void **)(to))[0] = janet_ffi_getpointer(argv, n); break; case JANET_FFI_TYPE_STRING: ((const char **)(to))[0] = janet_getcstring(argv, n); break; case JANET_FFI_TYPE_BOOL: ((bool *)(to))[0] = janet_getboolean(argv, n); break; case JANET_FFI_TYPE_INT8: ((int8_t *)(to))[0] = janet_getinteger(argv, n); break; case JANET_FFI_TYPE_INT16: ((int16_t *)(to))[0] = janet_getinteger(argv, n); break; case JANET_FFI_TYPE_INT32: ((int32_t *)(to))[0] = janet_getinteger(argv, n); break; case JANET_FFI_TYPE_INT64: ((int64_t *)(to))[0] = janet_getinteger64(argv, n); break; case JANET_FFI_TYPE_UINT8: ((uint8_t *)(to))[0] = (uint8_t) janet_getuinteger64(argv, n); break; case JANET_FFI_TYPE_UINT16: ((uint16_t *)(to))[0] = (uint16_t) janet_getuinteger64(argv, n); break; case JANET_FFI_TYPE_UINT32: ((uint32_t *)(to))[0] = (uint32_t) janet_getuinteger64(argv, n); break; case JANET_FFI_TYPE_UINT64: ((uint64_t *)(to))[0] = janet_getuinteger64(argv, n); break; } } /* Read a value from memory and construct a Janet data structure that can be passed back into * the interpreter. This should be the inverse to janet_ffi_write_one. It is assumed that the * size of the data is correct. */ static Janet janet_ffi_read_one(const uint8_t *from, JanetFFIType type, int recur) { if (recur == 0) janet_panic("recursion too deep"); if (type.array_count >= 0) { JanetFFIType el_type = type; el_type.array_count = -1; size_t el_size = type_size(el_type); JanetArray *array = janet_array(type.array_count); for (int32_t i = 0; i < type.array_count; i++) { janet_array_push(array, janet_ffi_read_one(from, el_type, recur - 1)); from += el_size; } return janet_wrap_array(array); } switch (type.prim) { default: case JANET_FFI_TYPE_VOID: return janet_wrap_nil(); case JANET_FFI_TYPE_STRUCT: { JanetFFIStruct *st = type.st; Janet *tup = janet_tuple_begin(st->field_count); for (uint32_t i = 0; i < st->field_count; i++) { JanetFFIType tp = st->fields[i].type; tup[i] = janet_ffi_read_one(from + st->fields[i].offset, tp, recur - 1); } return janet_wrap_tuple(janet_tuple_end(tup)); } case JANET_FFI_TYPE_DOUBLE: return janet_wrap_number(((double *)(from))[0]); case JANET_FFI_TYPE_FLOAT: return janet_wrap_number(((float *)(from))[0]); case JANET_FFI_TYPE_PTR: { void *ptr = ((void **)(from))[0]; return (NULL == ptr) ? janet_wrap_nil() : janet_wrap_pointer(ptr); } case JANET_FFI_TYPE_STRING: return janet_cstringv(((char **)(from))[0]); case JANET_FFI_TYPE_BOOL: return janet_wrap_boolean(((bool *)(from))[0]); case JANET_FFI_TYPE_INT8: return janet_wrap_number(((int8_t *)(from))[0]); case JANET_FFI_TYPE_INT16: return janet_wrap_number(((int16_t *)(from))[0]); case JANET_FFI_TYPE_INT32: return janet_wrap_number(((int32_t *)(from))[0]); case JANET_FFI_TYPE_UINT8: return janet_wrap_number(((uint8_t *)(from))[0]); case JANET_FFI_TYPE_UINT16: return janet_wrap_number(((uint16_t *)(from))[0]); case JANET_FFI_TYPE_UINT32: return janet_wrap_number(((uint32_t *)(from))[0]); #ifdef JANET_INT_TYPES case JANET_FFI_TYPE_INT64: return janet_wrap_s64(((int64_t *)(from))[0]); case JANET_FFI_TYPE_UINT64: return janet_wrap_u64(((uint64_t *)(from))[0]); #else case JANET_FFI_TYPE_INT64: return janet_wrap_number(((int64_t *)(from))[0]); case JANET_FFI_TYPE_UINT64: return janet_wrap_number(((uint64_t *)(from))[0]); #endif } } static JanetFFIMapping void_mapping(void) { JanetFFIMapping m; m.type = prim_type(JANET_FFI_TYPE_VOID); m.spec = JANET_SYSV64_NO_CLASS; m.offset = 0; return m; } #ifdef JANET_FFI_SYSV64_ENABLED /* AMD64 ABI Draft 0.99.7 – November 17, 2014 – 15:08 * See section 3.2.3 Parameter Passing */ static JanetFFIWordSpec sysv64_classify_ext(JanetFFIType type, size_t shift) { switch (type.prim) { case JANET_FFI_TYPE_PTR: case JANET_FFI_TYPE_STRING: case JANET_FFI_TYPE_BOOL: case JANET_FFI_TYPE_INT8: case JANET_FFI_TYPE_INT16: case JANET_FFI_TYPE_INT32: case JANET_FFI_TYPE_INT64: case JANET_FFI_TYPE_UINT8: case JANET_FFI_TYPE_UINT16: case JANET_FFI_TYPE_UINT32: case JANET_FFI_TYPE_UINT64: return JANET_SYSV64_INTEGER; case JANET_FFI_TYPE_DOUBLE: case JANET_FFI_TYPE_FLOAT: return JANET_SYSV64_SSE; case JANET_FFI_TYPE_STRUCT: { JanetFFIStruct *st = type.st; if (st->size > 16) return JANET_SYSV64_MEMORY; if (!st->is_aligned) return JANET_SYSV64_MEMORY; JanetFFIWordSpec clazz = JANET_SYSV64_NO_CLASS; if (st->size > 8 && st->size <= 16) { /* map to pair classification */ int has_int_lo = 0; int has_int_hi = 0; for (uint32_t i = 0; i < st->field_count; i++) { JanetFFIWordSpec next_class = sysv64_classify_ext(st->fields[i].type, shift + st->fields[i].offset); switch (next_class) { default: break; case JANET_SYSV64_INTEGER: if (shift + st->fields[i].offset + type_size(st->fields[i].type) <= 8) { has_int_lo = 1; } else { has_int_hi = 2; } break; case JANET_SYSV64_PAIR_INTINT: has_int_lo = 1; has_int_hi = 2; break; case JANET_SYSV64_PAIR_INTSSE: has_int_lo = 1; break; case JANET_SYSV64_PAIR_SSEINT: has_int_hi = 2; break; break; } } switch (has_int_hi + has_int_lo) { case 0: clazz = JANET_SYSV64_PAIR_SSESSE; break; case 1: clazz = JANET_SYSV64_PAIR_INTSSE; break; case 2: clazz = JANET_SYSV64_PAIR_SSEINT; break; case 3: clazz = JANET_SYSV64_PAIR_INTINT; break; } } else { /* Normal struct classification */ for (uint32_t i = 0; i < st->field_count; i++) { JanetFFIWordSpec next_class = sysv64_classify_ext(st->fields[i].type, shift + st->fields[i].offset); if (next_class != clazz) { if (clazz == JANET_SYSV64_NO_CLASS) { clazz = next_class; } else if (clazz == JANET_SYSV64_MEMORY || next_class == JANET_SYSV64_MEMORY) { clazz = JANET_SYSV64_MEMORY; } else if (clazz == JANET_SYSV64_INTEGER || next_class == JANET_SYSV64_INTEGER) { clazz = JANET_SYSV64_INTEGER; } else { clazz = JANET_SYSV64_SSE; } } } } return clazz; } case JANET_FFI_TYPE_VOID: return JANET_SYSV64_NO_CLASS; default: janet_panic("nyi"); return JANET_SYSV64_NO_CLASS; } } static JanetFFIWordSpec sysv64_classify(JanetFFIType type) { return sysv64_classify_ext(type, 0); } #endif #ifdef JANET_FFI_AAPCS64_ENABLED /* Procedure Call Standard for the Arm® 64-bit Architecture (AArch64) 2023Q3 – October 6, 2023 * See section 6.8.2 Parameter passing rules. * https://github.com/ARM-software/abi-aa/releases/download/2023Q3/aapcs64.pdf * * Additional documentation needed for Apple platforms. * https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms */ #define JANET_FFI_AAPCS64_FORCE_STACK_ALIGN(ptr, alignment) (ptr = ((ptr) + ((alignment) - 1)) & ~((alignment) - 1)) #if !defined(JANET_APPLE) #define JANET_FFI_AAPCS64_STACK_ALIGN(ptr, alignment) ((void) alignment, JANET_FFI_AAPCS64_FORCE_STACK_ALIGN(ptr, 8)) #else #define JANET_FFI_AAPCS64_STACK_ALIGN(ptr, alignment) JANET_FFI_AAPCS64_FORCE_STACK_ALIGN(ptr, alignment) #endif typedef struct { uint64_t a; uint64_t b; } Aapcs64Variant1ReturnGeneral; typedef struct { double a; double b; double c; double d; } Aapcs64Variant2ReturnSse; /* Workaround for passing a return value pointer through x8. * Limits struct returns to 128 bytes. */ typedef struct { uint64_t a; uint64_t b; uint64_t c; uint64_t d; uint64_t e; uint64_t f; uint64_t g; uint64_t h; uint64_t i; uint64_t j; uint64_t k; uint64_t l; uint64_t m; uint64_t n; uint64_t o; uint64_t p; } Aapcs64Variant3ReturnPointer; static JanetFFIWordSpec aapcs64_classify(JanetFFIType type) { switch (type.prim) { case JANET_FFI_TYPE_PTR: case JANET_FFI_TYPE_STRING: case JANET_FFI_TYPE_BOOL: case JANET_FFI_TYPE_INT8: case JANET_FFI_TYPE_INT16: case JANET_FFI_TYPE_INT32: case JANET_FFI_TYPE_INT64: case JANET_FFI_TYPE_UINT8: case JANET_FFI_TYPE_UINT16: case JANET_FFI_TYPE_UINT32: case JANET_FFI_TYPE_UINT64: return JANET_AAPCS64_GENERAL; case JANET_FFI_TYPE_DOUBLE: case JANET_FFI_TYPE_FLOAT: return JANET_AAPCS64_SSE; case JANET_FFI_TYPE_STRUCT: { JanetFFIStruct *st = type.st; if (st->field_count <= 4 && aapcs64_classify(st->fields[0].type) == JANET_AAPCS64_SSE) { bool is_hfa = true; for (uint32_t i = 1; i < st->field_count; i++) { if (st->fields[0].type.prim != st->fields[i].type.prim) { is_hfa = false; break; } } if (is_hfa) { return JANET_AAPCS64_SSE; } } if (type_size(type) > 16) { return JANET_AAPCS64_GENERAL_REF; } return JANET_AAPCS64_GENERAL; } case JANET_FFI_TYPE_VOID: return JANET_AAPCS64_NONE; default: janet_panic("nyi"); return JANET_AAPCS64_NONE; } } #endif JANET_CORE_FN(cfun_ffi_signature, "(ffi/signature calling-convention ret-type & arg-types)", "Create a function signature object that can be used to make calls " "with raw function pointers.") { janet_arity(argc, 2, -1); uint32_t frame_size = 0; uint32_t variant = 0; uint32_t arg_count = argc - 2; uint32_t stack_count = 0; JanetFFICallingConvention cc = decode_ffi_cc(janet_getkeyword(argv, 0)); JanetFFIType ret_type = decode_ffi_type(argv[1]); JanetFFIMapping ret = { ret_type, JANET_SYSV64_NO_CLASS, 0, 0 }; JanetFFIMapping mappings[JANET_FFI_MAX_ARGS]; for (int i = 0; i < JANET_FFI_MAX_ARGS; i++) mappings[i] = void_mapping(); switch (cc) { default: case JANET_FFI_CC_NONE: { /* Even if unsupported, we can check that the signature is valid * and error at runtime */ for (uint32_t i = 0; i < arg_count; i++) { decode_ffi_type(argv[i + 2]); } } break; #ifdef JANET_FFI_WIN64_ENABLED case JANET_FFI_CC_WIN_64: { size_t ret_size = type_size(ret.type); uint32_t ref_stack_count = 0; ret.spec = JANET_WIN64_REGISTER; uint32_t next_register = 0; if (ret_size != 0 && ret_size != 1 && ret_size != 2 && ret_size != 4 && ret_size != 8) { ret.spec = JANET_WIN64_REGISTER_REF; next_register++; } else if (ret.type.prim == JANET_FFI_TYPE_FLOAT || ret.type.prim == JANET_FFI_TYPE_DOUBLE) { variant += 16; } for (uint32_t i = 0; i < arg_count; i++) { mappings[i].type = decode_ffi_type(argv[i + 2]); size_t el_size = type_size(mappings[i].type); int is_register_sized = (el_size == 1 || el_size == 2 || el_size == 4 || el_size == 8); if (next_register < 4) { mappings[i].offset = next_register; if (is_register_sized) { mappings[i].spec = JANET_WIN64_REGISTER; if (mappings[i].type.prim == JANET_FFI_TYPE_FLOAT || mappings[i].type.prim == JANET_FFI_TYPE_DOUBLE) { variant += 1 << (3 - next_register); } } else { mappings[i].spec = JANET_WIN64_REGISTER_REF; mappings[i].offset2 = ref_stack_count; ref_stack_count += (uint32_t)((el_size + 15) / 16); } next_register++; } else { if (is_register_sized) { mappings[i].spec = JANET_WIN64_STACK; mappings[i].offset = stack_count; stack_count++; } else { mappings[i].spec = JANET_WIN64_STACK_REF; mappings[i].offset = stack_count; stack_count++; mappings[i].offset2 = ref_stack_count; ref_stack_count += (uint32_t)((el_size + 15) / 16); } } } /* Add reference items */ stack_count += 2 * ref_stack_count; if (stack_count & 0x1) { stack_count++; } /* Invert stack * Offsets are in units of 8-bytes */ for (uint32_t i = 0; i < arg_count; i++) { if (mappings[i].spec == JANET_WIN64_STACK_REF || mappings[i].spec == JANET_WIN64_REGISTER_REF) { /* Align size to 16 bytes */ size_t size = (type_size(mappings[i].type) + 15) & ~0xFUL; mappings[i].offset2 = (uint32_t)(stack_count - mappings[i].offset2 - (size / 8)); } } } break; #endif #ifdef JANET_FFI_SYSV64_ENABLED case JANET_FFI_CC_SYSV_64: { JanetFFIWordSpec ret_spec = sysv64_classify(ret.type); ret.spec = ret_spec; if (ret_spec == JANET_SYSV64_SSE) variant = 1; if (ret_spec == JANET_SYSV64_PAIR_INTSSE) variant = 2; if (ret_spec == JANET_SYSV64_PAIR_SSEINT) variant = 3; /* Spill register overflow to memory */ uint32_t next_register = 0; uint32_t next_fp_register = 0; const uint32_t max_regs = 6; const uint32_t max_fp_regs = 8; if (ret_spec == JANET_SYSV64_MEMORY) { /* First integer reg is pointer. */ next_register = 1; } for (uint32_t i = 0; i < arg_count; i++) { mappings[i].type = decode_ffi_type(argv[i + 2]); mappings[i].offset = 0; mappings[i].spec = sysv64_classify(mappings[i].type); if (mappings[i].spec == JANET_SYSV64_NO_CLASS) { janet_panic("unexpected void parameter"); } size_t el_size = (type_size(mappings[i].type) + 7) / 8; switch (mappings[i].spec) { default: janet_panicf("nyi: %d", mappings[i].spec); case JANET_SYSV64_INTEGER: { if (next_register < max_regs) { mappings[i].offset = next_register++; } else { mappings[i].spec = JANET_SYSV64_MEMORY; mappings[i].offset = stack_count; stack_count += el_size; } } break; case JANET_SYSV64_SSE: { if (next_fp_register < max_fp_regs) { mappings[i].offset = next_fp_register++; } else { mappings[i].spec = JANET_SYSV64_MEMORY; mappings[i].offset = stack_count; stack_count += el_size; } } break; case JANET_SYSV64_MEMORY: { mappings[i].offset = stack_count; stack_count += el_size; } break; case JANET_SYSV64_PAIR_INTINT: { if (next_register + 1 < max_regs) { mappings[i].offset = next_register++; mappings[i].offset2 = next_register++; } else { mappings[i].spec = JANET_SYSV64_MEMORY; mappings[i].offset = stack_count; stack_count += el_size; } } break; case JANET_SYSV64_PAIR_INTSSE: { if (next_register < max_regs && next_fp_register < max_fp_regs) { mappings[i].offset = next_register++; mappings[i].offset2 = next_fp_register++; } else { mappings[i].spec = JANET_SYSV64_MEMORY; mappings[i].offset = stack_count; stack_count += el_size; } } break; case JANET_SYSV64_PAIR_SSEINT: { if (next_register < max_regs && next_fp_register < max_fp_regs) { mappings[i].offset = next_fp_register++; mappings[i].offset2 = next_register++; } else { mappings[i].spec = JANET_SYSV64_MEMORY; mappings[i].offset = stack_count; stack_count += el_size; } } break; case JANET_SYSV64_PAIR_SSESSE: { if (next_fp_register < max_fp_regs) { mappings[i].offset = next_fp_register++; mappings[i].offset2 = next_fp_register++; } else { mappings[i].spec = JANET_SYSV64_MEMORY; mappings[i].offset = stack_count; stack_count += el_size; } } break; } } } break; #endif #ifdef JANET_FFI_AAPCS64_ENABLED case JANET_FFI_CC_AAPCS64: { uint32_t next_general_reg = 0; uint32_t next_fp_reg = 0; uint32_t stack_offset = 0; uint32_t ref_stack_offset = 0; JanetFFIWordSpec ret_spec = aapcs64_classify(ret_type); ret.spec = ret_spec; if (ret_spec == JANET_AAPCS64_SSE) { variant = 1; } else if (ret_spec == JANET_AAPCS64_GENERAL_REF) { if (type_size(ret_type) > sizeof(Aapcs64Variant3ReturnPointer)) { janet_panic("return value bigger than supported"); } variant = 2; } else { variant = 0; } for (uint32_t i = 0; i < arg_count; i++) { mappings[i].type = decode_ffi_type(argv[i + 2]); mappings[i].spec = aapcs64_classify(mappings[i].type); size_t arg_size = type_size(mappings[i].type); switch (mappings[i].spec) { case JANET_AAPCS64_GENERAL: { bool arg_is_struct = mappings[i].type.prim == JANET_FFI_TYPE_STRUCT; uint32_t needed_registers = (arg_size + 7) / 8; if (next_general_reg + needed_registers <= 8) { mappings[i].offset = next_general_reg; next_general_reg += needed_registers; } else { size_t arg_align = arg_is_struct ? 8 : type_align(mappings[i].type); mappings[i].spec = JANET_AAPCS64_STACK; mappings[i].offset = JANET_FFI_AAPCS64_STACK_ALIGN(stack_offset, arg_align); #if !defined(JANET_APPLE) stack_offset += arg_size > 8 ? arg_size : 8; #else stack_offset += arg_size; #endif next_general_reg = 8; } break; } case JANET_AAPCS64_GENERAL_REF: if (next_general_reg < 8) { mappings[i].offset = next_general_reg++; } else { mappings[i].spec = JANET_AAPCS64_STACK_REF; mappings[i].offset = JANET_FFI_AAPCS64_STACK_ALIGN(stack_offset, 8); stack_offset += 8; } mappings[i].offset2 = JANET_FFI_AAPCS64_FORCE_STACK_ALIGN(ref_stack_offset, 8); ref_stack_offset += arg_size; break; case JANET_AAPCS64_SSE: { uint32_t needed_registers = (arg_size + 7) / 8; if (next_fp_reg + needed_registers <= 8) { mappings[i].offset = next_fp_reg; next_fp_reg += needed_registers; } else { mappings[i].spec = JANET_AAPCS64_STACK; mappings[i].offset = JANET_FFI_AAPCS64_STACK_ALIGN(stack_offset, 8); #if !defined(JANET_APPLE) stack_offset += 8; #else stack_offset += arg_size; #endif } break; } default: janet_panic("nyi"); } } stack_offset = (stack_offset + 15) & ~0xFUL; ref_stack_offset = (ref_stack_offset + 15) & ~0xFUL; stack_count = stack_offset + ref_stack_offset; for (uint32_t i = 0; i < arg_count; i++) { if (mappings[i].spec == JANET_AAPCS64_GENERAL_REF || mappings[i].spec == JANET_AAPCS64_STACK_REF) { mappings[i].offset2 = stack_offset + mappings[i].offset2; } } } break; #endif } /* Create signature abstract value */ JanetFFISignature *abst = janet_abstract(&janet_signature_type, sizeof(JanetFFISignature)); abst->frame_size = frame_size; abst->cc = cc; abst->ret = ret; abst->arg_count = arg_count; abst->variant = variant; abst->stack_count = stack_count; memcpy(abst->args, mappings, sizeof(JanetFFIMapping) * JANET_FFI_MAX_ARGS); return janet_wrap_abstract(abst); } #ifdef JANET_FFI_SYSV64_ENABLED static void janet_ffi_sysv64_standard_callback(void *ctx, void *userdata) { janet_ffi_trampoline(ctx, userdata); } /* Functions that set all argument registers. Two variants - one to read rax and rdx returns, another * to read xmm0 and xmm1 returns. */ typedef struct { uint64_t x; uint64_t y; } sysv64_int_return; typedef struct { double x; double y; } sysv64_sse_return; typedef struct { uint64_t x; double y; } sysv64_intsse_return; typedef struct { double y; uint64_t x; } sysv64_sseint_return; typedef sysv64_int_return janet_sysv64_variant_1(uint64_t a, uint64_t b, uint64_t c, uint64_t d, uint64_t e, uint64_t f, double r1, double r2, double r3, double r4, double r5, double r6, double r7, double r8); typedef sysv64_sse_return janet_sysv64_variant_2(uint64_t a, uint64_t b, uint64_t c, uint64_t d, uint64_t e, uint64_t f, double r1, double r2, double r3, double r4, double r5, double r6, double r7, double r8); typedef sysv64_intsse_return janet_sysv64_variant_3(uint64_t a, uint64_t b, uint64_t c, uint64_t d, uint64_t e, uint64_t f, double r1, double r2, double r3, double r4, double r5, double r6, double r7, double r8); typedef sysv64_sseint_return janet_sysv64_variant_4(uint64_t a, uint64_t b, uint64_t c, uint64_t d, uint64_t e, uint64_t f, double r1, double r2, double r3, double r4, double r5, double r6, double r7, double r8); static Janet janet_ffi_sysv64(JanetFFISignature *signature, void *function_pointer, const Janet *argv) { union { sysv64_int_return int_return; sysv64_sse_return sse_return; sysv64_sseint_return sseint_return; sysv64_intsse_return intsse_return; } retu; uint64_t pair[2]; uint64_t regs[6]; double fp_regs[8]; JanetFFIWordSpec ret_spec = signature->ret.spec; void *ret_mem = &retu.int_return; if (ret_spec == JANET_SYSV64_MEMORY) { ret_mem = alloca(type_size(signature->ret.type)); regs[0] = (uint64_t) ret_mem; } uint64_t *stack = alloca(sizeof(uint64_t) * signature->stack_count); for (uint32_t i = 0; i < signature->arg_count; i++) { uint64_t *to; int32_t n = i + 2; JanetFFIMapping arg = signature->args[i]; switch (arg.spec) { default: janet_panic("nyi"); case JANET_SYSV64_INTEGER: to = regs + arg.offset; break; case JANET_SYSV64_SSE: to = (uint64_t *)(fp_regs + arg.offset); break; case JANET_SYSV64_MEMORY: to = stack + arg.offset; break; case JANET_SYSV64_PAIR_INTINT: janet_ffi_write_one(pair, argv, n, arg.type, JANET_FFI_MAX_RECUR); regs[arg.offset] = pair[0]; regs[arg.offset2] = pair[1]; continue; case JANET_SYSV64_PAIR_INTSSE: janet_ffi_write_one(pair, argv, n, arg.type, JANET_FFI_MAX_RECUR); regs[arg.offset] = pair[0]; ((uint64_t *) fp_regs)[arg.offset2] = pair[1]; continue; case JANET_SYSV64_PAIR_SSEINT: janet_ffi_write_one(pair, argv, n, arg.type, JANET_FFI_MAX_RECUR); ((uint64_t *) fp_regs)[arg.offset] = pair[0]; regs[arg.offset2] = pair[1]; continue; case JANET_SYSV64_PAIR_SSESSE: janet_ffi_write_one(pair, argv, n, arg.type, JANET_FFI_MAX_RECUR); ((uint64_t *) fp_regs)[arg.offset] = pair[0]; ((uint64_t *) fp_regs)[arg.offset2] = pair[1]; continue; } janet_ffi_write_one(to, argv, n, arg.type, JANET_FFI_MAX_RECUR); } switch (signature->variant) { case 0: retu.int_return = ((janet_sysv64_variant_1 *)(function_pointer))( regs[0], regs[1], regs[2], regs[3], regs[4], regs[5], fp_regs[0], fp_regs[1], fp_regs[2], fp_regs[3], fp_regs[4], fp_regs[5], fp_regs[6], fp_regs[7]); break; case 1: retu.sse_return = ((janet_sysv64_variant_2 *)(function_pointer))( regs[0], regs[1], regs[2], regs[3], regs[4], regs[5], fp_regs[0], fp_regs[1], fp_regs[2], fp_regs[3], fp_regs[4], fp_regs[5], fp_regs[6], fp_regs[7]); break; case 2: retu.intsse_return = ((janet_sysv64_variant_3 *)(function_pointer))( regs[0], regs[1], regs[2], regs[3], regs[4], regs[5], fp_regs[0], fp_regs[1], fp_regs[2], fp_regs[3], fp_regs[4], fp_regs[5], fp_regs[6], fp_regs[7]); break; case 3: retu.sseint_return = ((janet_sysv64_variant_4 *)(function_pointer))( regs[0], regs[1], regs[2], regs[3], regs[4], regs[5], fp_regs[0], fp_regs[1], fp_regs[2], fp_regs[3], fp_regs[4], fp_regs[5], fp_regs[6], fp_regs[7]); break; } return janet_ffi_read_one(ret_mem, signature->ret.type, JANET_FFI_MAX_RECUR); } #endif #ifdef JANET_FFI_WIN64_ENABLED static void janet_ffi_win64_standard_callback(void *ctx, void *userdata) { janet_ffi_trampoline(ctx, userdata); } /* Variants that allow setting all required registers for 64 bit windows calling convention. * win64 calling convention has up to 4 arguments on registers, and one register for returns. * Each register can either be an integer or floating point register, resulting in * 2^5 = 32 variants. Unlike sysv, there are no function signatures that will fill * all of the possible registers which is why we have so many variants. If you were using * assembly, you could manually fill all of the registers and only have a single variant. * And msvc does not support inline assembly on 64 bit targets, so yeah, we have this hackery. */ typedef uint64_t (win64_variant_i_iiii)(uint64_t, uint64_t, uint64_t, uint64_t); typedef uint64_t (win64_variant_i_iiif)(uint64_t, uint64_t, uint64_t, double); typedef uint64_t (win64_variant_i_iifi)(uint64_t, uint64_t, double, uint64_t); typedef uint64_t (win64_variant_i_iiff)(uint64_t, uint64_t, double, double); typedef uint64_t (win64_variant_i_ifii)(uint64_t, double, uint64_t, uint64_t); typedef uint64_t (win64_variant_i_ifif)(uint64_t, double, uint64_t, double); typedef uint64_t (win64_variant_i_iffi)(uint64_t, double, double, uint64_t); typedef uint64_t (win64_variant_i_ifff)(uint64_t, double, double, double); typedef uint64_t (win64_variant_i_fiii)(double, uint64_t, uint64_t, uint64_t); typedef uint64_t (win64_variant_i_fiif)(double, uint64_t, uint64_t, double); typedef uint64_t (win64_variant_i_fifi)(double, uint64_t, double, uint64_t); typedef uint64_t (win64_variant_i_fiff)(double, uint64_t, double, double); typedef uint64_t (win64_variant_i_ffii)(double, double, uint64_t, uint64_t); typedef uint64_t (win64_variant_i_ffif)(double, double, uint64_t, double); typedef uint64_t (win64_variant_i_fffi)(double, double, double, uint64_t); typedef uint64_t (win64_variant_i_ffff)(double, double, double, double); typedef double (win64_variant_f_iiii)(uint64_t, uint64_t, uint64_t, uint64_t); typedef double (win64_variant_f_iiif)(uint64_t, uint64_t, uint64_t, double); typedef double (win64_variant_f_iifi)(uint64_t, uint64_t, double, uint64_t); typedef double (win64_variant_f_iiff)(uint64_t, uint64_t, double, double); typedef double (win64_variant_f_ifii)(uint64_t, double, uint64_t, uint64_t); typedef double (win64_variant_f_ifif)(uint64_t, double, uint64_t, double); typedef double (win64_variant_f_iffi)(uint64_t, double, double, uint64_t); typedef double (win64_variant_f_ifff)(uint64_t, double, double, double); typedef double (win64_variant_f_fiii)(double, uint64_t, uint64_t, uint64_t); typedef double (win64_variant_f_fiif)(double, uint64_t, uint64_t, double); typedef double (win64_variant_f_fifi)(double, uint64_t, double, uint64_t); typedef double (win64_variant_f_fiff)(double, uint64_t, double, double); typedef double (win64_variant_f_ffii)(double, double, uint64_t, uint64_t); typedef double (win64_variant_f_ffif)(double, double, uint64_t, double); typedef double (win64_variant_f_fffi)(double, double, double, uint64_t); typedef double (win64_variant_f_ffff)(double, double, double, double); /* MSVC stack frame runtime error checking (/RTCs) prepends alloca() allocations with an _RTC_ALLOCA_NODE * header; misalligning stack-based FFI arguments and causing the memmove() (by stack_shift) to corrupt * the _RTC_ALLOCA_NODE header. * * We turn off the RTC-instrumented alloca() and adding of _RTC_CheckStackVars to function prologue just * for janet_ffi_win64() */ #ifdef __MSVC_RUNTIME_CHECKS #pragma runtime_checks( "s", off ) #endif static Janet janet_ffi_win64(JanetFFISignature *signature, void *function_pointer, const Janet *argv) { union { uint64_t integer; double real; } regs[4]; union { uint64_t integer; double real; } ret_reg; JanetFFIWordSpec ret_spec = signature->ret.spec; void *ret_mem = &ret_reg.integer; if (ret_spec == JANET_WIN64_REGISTER_REF) { ret_mem = alloca(type_size(signature->ret.type)); regs[0].integer = (uint64_t) ret_mem; } size_t stack_size = signature->stack_count * 8; size_t stack_shift = 2; uint64_t *stack = alloca(stack_size); for (uint32_t i = 0; i < signature->arg_count; i++) { int32_t n = i + 2; JanetFFIMapping arg = signature->args[i]; if (arg.spec == JANET_WIN64_STACK) { janet_ffi_write_one(stack + arg.offset, argv, n, arg.type, JANET_FFI_MAX_RECUR); } else if (arg.spec == JANET_WIN64_STACK_REF) { uint8_t *ptr = (uint8_t *)(stack + arg.offset2); janet_ffi_write_one(ptr, argv, n, arg.type, JANET_FFI_MAX_RECUR); stack[arg.offset] = (uint64_t)(ptr - stack_shift * sizeof(uint64_t)); } else if (arg.spec == JANET_WIN64_REGISTER_REF) { uint8_t *ptr = (uint8_t *)(stack + arg.offset2); janet_ffi_write_one(ptr, argv, n, arg.type, JANET_FFI_MAX_RECUR); regs[arg.offset].integer = (uint64_t)(ptr - stack_shift * sizeof(uint64_t)); } else { janet_ffi_write_one((uint8_t *) ®s[arg.offset].integer, argv, n, arg.type, JANET_FFI_MAX_RECUR); } } /* hack to get proper stack placement and avoid clobbering from logic above - shift stack down, otherwise we have issues. * Technically, this writes into 16 bytes of unallocated stack memory */ #ifdef JANET_MINGW #pragma GCC diagnostic ignored "-Wstringop-overflow" #endif if (stack_size) memmove(stack - stack_shift, stack, stack_size); #ifdef JANET_MINGW #pragma GCC diagnostic pop #endif switch (signature->variant) { default: janet_panicf("unknown variant %d", signature->variant); case 0: ret_reg.integer = ((win64_variant_i_iiii *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].integer, regs[3].integer); break; case 1: ret_reg.integer = ((win64_variant_i_iiif *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].integer, regs[3].real); break; case 2: ret_reg.integer = ((win64_variant_i_iifi *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].real, regs[3].integer); break; case 3: ret_reg.integer = ((win64_variant_i_iiff *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].real, regs[3].real); break; case 4: ret_reg.integer = ((win64_variant_i_ifii *) function_pointer)(regs[0].integer, regs[1].real, regs[2].integer, regs[3].integer); break; case 5: ret_reg.integer = ((win64_variant_i_ifif *) function_pointer)(regs[0].integer, regs[1].real, regs[2].integer, regs[3].real); break; case 6: ret_reg.integer = ((win64_variant_i_iffi *) function_pointer)(regs[0].integer, regs[1].real, regs[2].real, regs[3].integer); break; case 7: ret_reg.integer = ((win64_variant_i_ifff *) function_pointer)(regs[0].integer, regs[1].real, regs[2].real, regs[3].real); break; case 8: ret_reg.integer = ((win64_variant_i_fiii *) function_pointer)(regs[0].real, regs[1].integer, regs[2].integer, regs[3].integer); break; case 9: ret_reg.integer = ((win64_variant_i_fiif *) function_pointer)(regs[0].real, regs[1].integer, regs[2].integer, regs[3].real); break; case 10: ret_reg.integer = ((win64_variant_i_fifi *) function_pointer)(regs[0].real, regs[1].integer, regs[2].real, regs[3].integer); break; case 11: ret_reg.integer = ((win64_variant_i_fiff *) function_pointer)(regs[0].real, regs[1].integer, regs[2].real, regs[3].real); break; case 12: ret_reg.integer = ((win64_variant_i_ffii *) function_pointer)(regs[0].real, regs[1].real, regs[2].integer, regs[3].integer); break; case 13: ret_reg.integer = ((win64_variant_i_ffif *) function_pointer)(regs[0].real, regs[1].real, regs[2].integer, regs[3].real); break; case 14: ret_reg.integer = ((win64_variant_i_fffi *) function_pointer)(regs[0].real, regs[1].real, regs[2].real, regs[3].integer); break; case 15: ret_reg.integer = ((win64_variant_i_ffff *) function_pointer)(regs[0].real, regs[1].real, regs[2].real, regs[3].real); break; case 16: ret_reg.real = ((win64_variant_f_iiii *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].integer, regs[3].integer); break; case 17: ret_reg.real = ((win64_variant_f_iiif *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].integer, regs[3].real); break; case 18: ret_reg.real = ((win64_variant_f_iifi *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].real, regs[3].integer); break; case 19: ret_reg.real = ((win64_variant_f_iiff *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].real, regs[3].real); break; case 20: ret_reg.real = ((win64_variant_f_ifii *) function_pointer)(regs[0].integer, regs[1].real, regs[2].integer, regs[3].integer); break; case 21: ret_reg.real = ((win64_variant_f_ifif *) function_pointer)(regs[0].integer, regs[1].real, regs[2].integer, regs[3].real); break; case 22: ret_reg.real = ((win64_variant_f_iffi *) function_pointer)(regs[0].integer, regs[1].real, regs[2].real, regs[3].integer); break; case 23: ret_reg.real = ((win64_variant_f_ifff *) function_pointer)(regs[0].integer, regs[1].real, regs[2].real, regs[3].real); break; case 24: ret_reg.real = ((win64_variant_f_fiii *) function_pointer)(regs[0].real, regs[1].integer, regs[2].integer, regs[3].integer); break; case 25: ret_reg.real = ((win64_variant_f_fiif *) function_pointer)(regs[0].real, regs[1].integer, regs[2].integer, regs[3].real); break; case 26: ret_reg.real = ((win64_variant_f_fifi *) function_pointer)(regs[0].real, regs[1].integer, regs[2].real, regs[3].integer); break; case 27: ret_reg.real = ((win64_variant_f_fiff *) function_pointer)(regs[0].real, regs[1].integer, regs[2].real, regs[3].real); break; case 28: ret_reg.real = ((win64_variant_f_ffii *) function_pointer)(regs[0].real, regs[1].real, regs[2].integer, regs[3].integer); break; case 29: ret_reg.real = ((win64_variant_f_ffif *) function_pointer)(regs[0].real, regs[1].real, regs[2].integer, regs[3].real); break; case 30: ret_reg.real = ((win64_variant_f_fffi *) function_pointer)(regs[0].real, regs[1].real, regs[2].real, regs[3].integer); break; case 31: ret_reg.real = ((win64_variant_f_ffff *) function_pointer)(regs[0].real, regs[1].real, regs[2].real, regs[3].real); break; } return janet_ffi_read_one(ret_mem, signature->ret.type, JANET_FFI_MAX_RECUR); } #ifdef __MSVC_RUNTIME_CHECKS // Restore stack frame runtime error checking (/RTCs) if it was enabled. #pragma runtime_checks ( "s", restore ) #endif #endif #ifdef JANET_FFI_AAPCS64_ENABLED static void janet_ffi_aapcs64_standard_callback(void *ctx, void *userdata) { janet_ffi_trampoline(ctx, userdata); } typedef Aapcs64Variant1ReturnGeneral janet_aapcs64_variant_1(uint64_t x0, uint64_t x1, uint64_t x2, uint64_t x3, uint64_t x4, uint64_t x5, uint64_t x6, uint64_t x7, double v0, double v1, double v2, double v3, double v4, double v5, double v6, double v7); typedef Aapcs64Variant2ReturnSse janet_aapcs64_variant_2(uint64_t x0, uint64_t x1, uint64_t x2, uint64_t x3, uint64_t x4, uint64_t x5, uint64_t x6, uint64_t x7, double v0, double v1, double v2, double v3, double v4, double v5, double v6, double v7); typedef Aapcs64Variant3ReturnPointer janet_aapcs64_variant_3(uint64_t x0, uint64_t x1, uint64_t x2, uint64_t x3, uint64_t x4, uint64_t x5, uint64_t x6, uint64_t x7, double v0, double v1, double v2, double v3, double v4, double v5, double v6, double v7); static Janet janet_ffi_aapcs64(JanetFFISignature *signature, void *function_pointer, const Janet *argv) { union { Aapcs64Variant1ReturnGeneral general_return; Aapcs64Variant2ReturnSse sse_return; Aapcs64Variant3ReturnPointer pointer_return; } retu; uint64_t regs[8]; double fp_regs[8]; void *ret_mem = &retu.general_return; /* Apple's stack values do not need to be 8-byte aligned, * thus all stack offsets refer to actual byte positions. */ uint8_t *stack = alloca(signature->stack_count); #if defined(JANET_APPLE) /* Values must be zero-extended by the caller instead of the callee. */ memset(stack, 0, signature->stack_count); #endif for (uint32_t i = 0; i < signature->arg_count; i++) { int32_t n = i + 2; JanetFFIMapping arg = signature->args[i]; void *to = NULL; switch (arg.spec) { case JANET_AAPCS64_GENERAL: to = regs + arg.offset; break; case JANET_AAPCS64_GENERAL_REF: to = stack + arg.offset2; regs[arg.offset] = (uint64_t) to; break; case JANET_AAPCS64_SSE: to = fp_regs + arg.offset; break; case JANET_AAPCS64_STACK: to = stack + arg.offset; break; case JANET_AAPCS64_STACK_REF: to = stack + arg.offset2; uint64_t *ptr = (uint64_t *) stack + arg.offset; *ptr = (uint64_t) to; break; default: janet_panic("nyi"); } if (to) { janet_ffi_write_one(to, argv, n, arg.type, JANET_FFI_MAX_RECUR); } } switch (signature->variant) { case 0: retu.general_return = ((janet_aapcs64_variant_1 *)(function_pointer))( regs[0], regs[1], regs[2], regs[3], regs[4], regs[5], regs[6], regs[7], fp_regs[0], fp_regs[1], fp_regs[2], fp_regs[3], fp_regs[4], fp_regs[5], fp_regs[6], fp_regs[7]); break; case 1: retu.sse_return = ((janet_aapcs64_variant_2 *)(function_pointer))( regs[0], regs[1], regs[2], regs[3], regs[4], regs[5], regs[6], regs[7], fp_regs[0], fp_regs[1], fp_regs[2], fp_regs[3], fp_regs[4], fp_regs[5], fp_regs[6], fp_regs[7]); break; case 2: { retu.pointer_return = ((janet_aapcs64_variant_3 *)(function_pointer))( regs[0], regs[1], regs[2], regs[3], regs[4], regs[5], regs[6], regs[7], fp_regs[0], fp_regs[1], fp_regs[2], fp_regs[3], fp_regs[4], fp_regs[5], fp_regs[6], fp_regs[7]); } } return janet_ffi_read_one(ret_mem, signature->ret.type, JANET_FFI_MAX_RECUR); } #endif /* Allocate executable memory chunks in sizes of a page. Ideally we would keep * an allocator around so that multiple JIT allocations would point to the same * region but it isn't really worth it. */ #define FFI_PAGE_MASK 0xFFF JANET_CORE_FN(cfun_ffi_jitfn, "(ffi/jitfn bytes)", "Create an abstract type that can be used as the pointer argument to `ffi/call`. The content " "of `bytes` is architecture specific machine code that will be copied into executable memory.") { janet_sandbox_assert(JANET_SANDBOX_FFI_JIT); janet_fixarity(argc, 1); JanetByteView bytes = janet_getbytes(argv, 0); /* Quick hack to align to page boundary, we should query OS. FIXME */ size_t alloc_size = ((size_t) bytes.len + FFI_PAGE_MASK) & ~FFI_PAGE_MASK; #ifdef JANET_FFI_JIT #ifdef JANET_EV JanetFFIJittedFn *fn = janet_abstract_threaded(&janet_type_ffijit, sizeof(JanetFFIJittedFn)); #else JanetFFIJittedFn *fn = janet_abstract(&janet_type_ffijit, sizeof(JanetFFIJittedFn)); #endif fn->function_pointer = NULL; fn->size = 0; #ifdef JANET_WINDOWS void *ptr = VirtualAlloc(NULL, alloc_size, MEM_COMMIT | MEM_RESERVE, PAGE_READWRITE); #elif defined(MAP_ANONYMOUS) void *ptr = mmap(0, alloc_size, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); #elif defined(MAP_ANON) /* macos doesn't have MAP_ANONYMOUS */ void *ptr = mmap(0, alloc_size, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANON, -1, 0); #else /* -std=c99 gets in the way */ /* #define MAP_ANONYMOUS 0x20 should work, though. */ void *ptr = mmap(0, alloc_size, PROT_READ | PROT_WRITE, MAP_PRIVATE, -1, 0); #endif if (!ptr) { janet_panic("failed to memory map writable memory"); } memcpy(ptr, bytes.bytes, bytes.len); #ifdef JANET_WINDOWS DWORD old = 0; if (!VirtualProtect(ptr, alloc_size, PAGE_EXECUTE_READ, &old)) { janet_panic("failed to make mapped memory executable"); } #else if (mprotect(ptr, alloc_size, PROT_READ | PROT_EXEC) == -1) { janet_panic("failed to make mapped memory executable"); } #endif fn->size = alloc_size; fn->function_pointer = ptr; return janet_wrap_abstract(fn); #else janet_panic("ffi/jitfn not available on this platform"); #endif } JANET_CORE_FN(cfun_ffi_call, "(ffi/call pointer signature & args)", "Call a raw pointer as a function pointer. The function signature specifies " "how Janet values in `args` are converted to native machine types.") { janet_sandbox_assert(JANET_SANDBOX_FFI_USE); janet_arity(argc, 2, -1); void *function_pointer = janet_ffi_get_callable_pointer(argv, 0); JanetFFISignature *signature = janet_getabstract(argv, 1, &janet_signature_type); janet_fixarity(argc - 2, signature->arg_count); switch (signature->cc) { default: case JANET_FFI_CC_NONE: (void) function_pointer; janet_panic("calling convention not supported"); #ifdef JANET_FFI_WIN64_ENABLED case JANET_FFI_CC_WIN_64: return janet_ffi_win64(signature, function_pointer, argv); #endif #ifdef JANET_FFI_SYSV64_ENABLED case JANET_FFI_CC_SYSV_64: return janet_ffi_sysv64(signature, function_pointer, argv); #endif #ifdef JANET_FFI_AAPCS64_ENABLED case JANET_FFI_CC_AAPCS64: return janet_ffi_aapcs64(signature, function_pointer, argv); #endif } } JANET_CORE_FN(cfun_ffi_buffer_write, "(ffi/write ffi-type data &opt buffer index)", "Append a native type to a buffer such as it would appear in memory. This can be used " "to pass pointers to structs in the ffi, or send C/C++/native structs over the network " "or to files. Returns a modified buffer or a new buffer if one is not supplied.") { janet_sandbox_assert(JANET_SANDBOX_FFI_USE); janet_arity(argc, 2, 4); JanetFFIType type = decode_ffi_type(argv[0]); uint32_t el_size = (uint32_t) type_size(type); JanetBuffer *buffer = janet_optbuffer(argv, argc, 2, el_size); int32_t index = janet_optnat(argv, argc, 3, buffer->count); int32_t old_count = buffer->count; if (index > old_count) janet_panic("index out of bounds"); buffer->count = index; janet_buffer_extra(buffer, el_size); buffer->count = old_count; memset(buffer->data + index, 0, el_size); janet_ffi_write_one(buffer->data + index, argv, 1, type, JANET_FFI_MAX_RECUR); index += el_size; if (buffer->count < index) buffer->count = index; return janet_wrap_buffer(buffer); } JANET_CORE_FN(cfun_ffi_buffer_read, "(ffi/read ffi-type bytes &opt offset)", "Parse a native struct out of a buffer and convert it to normal Janet data structures. " "This function is the inverse of `ffi/write`. `bytes` can also be a raw pointer, although " "this is unsafe.") { janet_sandbox_assert(JANET_SANDBOX_FFI_USE); janet_arity(argc, 2, 3); JanetFFIType type = decode_ffi_type(argv[0]); size_t offset = (size_t) janet_optnat(argv, argc, 2, 0); if (janet_checktype(argv[1], JANET_POINTER)) { uint8_t *ptr = janet_unwrap_pointer(argv[1]); return janet_ffi_read_one(ptr + offset, type, JANET_FFI_MAX_RECUR); } else { size_t el_size = type_size(type); JanetByteView bytes = janet_getbytes(argv, 1); if ((size_t) bytes.len < offset + el_size) janet_panic("read out of range"); return janet_ffi_read_one(bytes.bytes + offset, type, JANET_FFI_MAX_RECUR); } } JANET_CORE_FN(cfun_ffi_get_callback_trampoline, "(ffi/trampoline cc)", "Get a native function pointer that can be used as a callback and passed to C libraries. " "This callback trampoline has the signature `void trampoline(void \\*ctx, void \\*userdata)` in " "the given calling convention. This is the only function signature supported. " "It is up to the programmer to ensure that the `userdata` argument contains a janet function " "the will be called with one argument, `ctx` which is an opaque pointer. This pointer can " "be further inspected with `ffi/read`.") { janet_arity(argc, 0, 1); JanetFFICallingConvention cc = JANET_FFI_CC_DEFAULT; if (argc >= 1) cc = decode_ffi_cc(janet_getkeyword(argv, 0)); switch (cc) { default: case JANET_FFI_CC_NONE: janet_panic("calling convention not supported"); #ifdef JANET_FFI_WIN64_ENABLED case JANET_FFI_CC_WIN_64: return janet_wrap_pointer(janet_ffi_win64_standard_callback); #endif #ifdef JANET_FFI_SYSV64_ENABLED case JANET_FFI_CC_SYSV_64: return janet_wrap_pointer(janet_ffi_sysv64_standard_callback); #endif #ifdef JANET_FFI_AAPCS64_ENABLED case JANET_FFI_CC_AAPCS64: return janet_wrap_pointer(janet_ffi_aapcs64_standard_callback); #endif } } JANET_CORE_FN(janet_core_raw_native, "(ffi/native &opt path)", "Load a shared object or dll from the given path, and do not extract" " or run any code from it. This is different than `native`, which will " "run initialization code to get a module table. If `path` is nil, opens the current running binary. " "Returns a `core/native`.") { janet_sandbox_assert(JANET_SANDBOX_FFI_DEFINE); janet_arity(argc, 0, 1); const char *path = janet_optcstring(argv, argc, 0, NULL); Clib lib = load_clib(path); if (!lib) janet_panic(error_clib()); JanetAbstractNative *anative = janet_abstract(&janet_native_type, sizeof(JanetAbstractNative)); anative->clib = lib; anative->closed = 0; anative->is_self = path == NULL; return janet_wrap_abstract(anative); } JANET_CORE_FN(janet_core_native_lookup, "(ffi/lookup native symbol-name)", "Lookup a symbol from a native object. All symbol lookups will return a raw pointer " "if the symbol is found, else nil.") { janet_sandbox_assert(JANET_SANDBOX_FFI_DEFINE); janet_fixarity(argc, 2); JanetAbstractNative *anative = janet_getabstract(argv, 0, &janet_native_type); const char *sym = janet_getcstring(argv, 1); if (anative->closed) janet_panic("native object already closed"); void *value = symbol_clib(anative->clib, sym); if (NULL == value) return janet_wrap_nil(); return janet_wrap_pointer(value); } JANET_CORE_FN(janet_core_native_close, "(ffi/close native)", "Free a native object. Dereferencing pointers to symbols in the object will have undefined " "behavior after freeing.") { janet_sandbox_assert(JANET_SANDBOX_FFI_DEFINE); janet_fixarity(argc, 1); JanetAbstractNative *anative = janet_getabstract(argv, 0, &janet_native_type); if (anative->closed) janet_panic("native object already closed"); if (anative->is_self) janet_panic("cannot close self"); anative->closed = 1; free_clib(anative->clib); return janet_wrap_nil(); } JANET_CORE_FN(cfun_ffi_malloc, "(ffi/malloc size)", "Allocates memory directly using the janet memory allocator. Memory allocated in this way must be freed manually! Returns a raw pointer, or nil if size = 0.") { janet_sandbox_assert(JANET_SANDBOX_FFI_USE); janet_fixarity(argc, 1); size_t size = janet_getsize(argv, 0); if (size == 0) return janet_wrap_nil(); return janet_wrap_pointer(janet_malloc(size)); } JANET_CORE_FN(cfun_ffi_free, "(ffi/free pointer)", "Free memory allocated with `ffi/malloc`. Returns nil.") { janet_sandbox_assert(JANET_SANDBOX_FFI_USE); janet_fixarity(argc, 1); if (janet_checktype(argv[0], JANET_NIL)) return janet_wrap_nil(); void *pointer = janet_getpointer(argv, 0); janet_free(pointer); return janet_wrap_nil(); } JANET_CORE_FN(cfun_ffi_pointer_buffer, "(ffi/pointer-buffer pointer capacity &opt count offset)", "Create a buffer from a pointer. The underlying memory of the buffer will not be " "reallocated or freed by the garbage collector, allowing unmanaged, mutable memory " "to be manipulated with buffer functions. Attempts to resize or extend the buffer " "beyond its initial capacity will raise an error. As with many FFI functions, this is memory " "unsafe and can potentially allow out of bounds memory access. Returns a new buffer.") { janet_sandbox_assert(JANET_SANDBOX_FFI_USE); janet_arity(argc, 2, 4); void *pointer = janet_getpointer(argv, 0); int32_t capacity = janet_getnat(argv, 1); int32_t count = janet_optnat(argv, argc, 2, 0); int64_t offset = janet_optinteger64(argv, argc, 3, 0); uint8_t *offset_pointer = ((uint8_t *) pointer) + offset; return janet_wrap_buffer(janet_pointer_buffer_unsafe(offset_pointer, capacity, count)); } JANET_CORE_FN(cfun_ffi_pointer_cfunction, "(ffi/pointer-cfunction pointer &opt name source-file source-line)", "Create a C Function from a raw pointer. Optionally give the cfunction a name and " "source location for stack traces and debugging.") { janet_sandbox_assert(JANET_SANDBOX_FFI_USE); janet_arity(argc, 1, 4); void *pointer = janet_getpointer(argv, 0); const char *name = janet_optcstring(argv, argc, 1, NULL); const char *source = janet_optcstring(argv, argc, 2, NULL); int32_t line = janet_optinteger(argv, argc, 3, -1); if ((name != NULL) || (source != NULL) || (line != -1)) { janet_registry_put((JanetCFunction) pointer, name, NULL, source, line); } return janet_wrap_cfunction((JanetCFunction) pointer); } JANET_CORE_FN(cfun_ffi_supported_calling_conventions, "(ffi/calling-conventions)", "Get an array of all supported calling conventions on the current architecture. Some architectures may have some FFI " "functionality (ffi/malloc, ffi/free, ffi/read, ffi/write, etc.) but not support " "any calling conventions. This function can be used to get all supported calling conventions " "that can be used on this architecture. All architectures support the :none calling " "convention which is a placeholder that cannot be used at runtime.") { janet_fixarity(argc, 0); (void) argv; JanetArray *array = janet_array(4); #ifdef JANET_FFI_WIN64_ENABLED janet_array_push(array, janet_ckeywordv("win64")); #endif #ifdef JANET_FFI_SYSV64_ENABLED janet_array_push(array, janet_ckeywordv("sysv64")); #endif #ifdef JANET_FFI_AAPCS64_ENABLED janet_array_push(array, janet_ckeywordv("aapcs64")); #endif janet_array_push(array, janet_ckeywordv("none")); return janet_wrap_array(array); } void janet_lib_ffi(JanetTable *env) { JanetRegExt ffi_cfuns[] = { JANET_CORE_REG("ffi/native", janet_core_raw_native), JANET_CORE_REG("ffi/lookup", janet_core_native_lookup), JANET_CORE_REG("ffi/close", janet_core_native_close), JANET_CORE_REG("ffi/signature", cfun_ffi_signature), JANET_CORE_REG("ffi/call", cfun_ffi_call), JANET_CORE_REG("ffi/struct", cfun_ffi_struct), JANET_CORE_REG("ffi/write", cfun_ffi_buffer_write), JANET_CORE_REG("ffi/read", cfun_ffi_buffer_read), JANET_CORE_REG("ffi/size", cfun_ffi_size), JANET_CORE_REG("ffi/align", cfun_ffi_align), JANET_CORE_REG("ffi/trampoline", cfun_ffi_get_callback_trampoline), JANET_CORE_REG("ffi/jitfn", cfun_ffi_jitfn), JANET_CORE_REG("ffi/malloc", cfun_ffi_malloc), JANET_CORE_REG("ffi/free", cfun_ffi_free), JANET_CORE_REG("ffi/pointer-buffer", cfun_ffi_pointer_buffer), JANET_CORE_REG("ffi/pointer-cfunction", cfun_ffi_pointer_cfunction), JANET_CORE_REG("ffi/calling-conventions", cfun_ffi_supported_calling_conventions), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, ffi_cfuns); } #endif janet-1.41.2/src/core/fiber.c000066400000000000000000000624461514534607600157010ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "fiber.h" #include "state.h" #include "gc.h" #include "util.h" #endif static void fiber_reset(JanetFiber *fiber) { fiber->maxstack = JANET_STACK_MAX; fiber->frame = 0; fiber->stackstart = JANET_FRAME_SIZE; fiber->stacktop = JANET_FRAME_SIZE; fiber->child = NULL; fiber->flags = JANET_FIBER_MASK_YIELD | JANET_FIBER_RESUME_NO_USEVAL | JANET_FIBER_RESUME_NO_SKIP; fiber->env = NULL; fiber->last_value = janet_wrap_nil(); #ifdef JANET_EV fiber->sched_id = 0; fiber->ev_callback = NULL; fiber->ev_state = NULL; fiber->ev_stream = NULL; fiber->supervisor_channel = NULL; #endif janet_fiber_set_status(fiber, JANET_STATUS_NEW); } static JanetFiber *fiber_alloc(int32_t capacity) { Janet *data; JanetFiber *fiber = janet_gcalloc(JANET_MEMORY_FIBER, sizeof(JanetFiber)); if (capacity < 32) { capacity = 32; } fiber->capacity = capacity; data = janet_malloc(sizeof(Janet) * (size_t) capacity); if (NULL == data) { JANET_OUT_OF_MEMORY; } janet_vm.next_collection += sizeof(Janet) * capacity; fiber->data = data; return fiber; } /* Create a new fiber with argn values on the stack by reusing a fiber. */ JanetFiber *janet_fiber_reset(JanetFiber *fiber, JanetFunction *callee, int32_t argc, const Janet *argv) { int32_t newstacktop; fiber_reset(fiber); if (argc) { newstacktop = fiber->stacktop + argc; if (newstacktop >= fiber->capacity) { janet_fiber_setcapacity(fiber, 2 * newstacktop); } if (argv) { memcpy(fiber->data + fiber->stacktop, argv, argc * sizeof(Janet)); } else { /* If argv not given, fill with nil */ for (int32_t i = 0; i < argc; i++) { fiber->data[fiber->stacktop + i] = janet_wrap_nil(); } } fiber->stacktop = newstacktop; } /* Don't panic on failure since we use this to implement janet_pcall */ if (janet_fiber_funcframe(fiber, callee)) return NULL; janet_fiber_frame(fiber)->flags |= JANET_STACKFRAME_ENTRANCE; #ifdef JANET_EV fiber->supervisor_channel = NULL; #endif return fiber; } /* Create a new fiber with argn values on the stack. */ JanetFiber *janet_fiber(JanetFunction *callee, int32_t capacity, int32_t argc, const Janet *argv) { return janet_fiber_reset(fiber_alloc(capacity), callee, argc, argv); } #ifdef JANET_DEBUG /* Test for memory issues by reallocating fiber every time we push a stack frame */ static void janet_fiber_refresh_memory(JanetFiber *fiber) { int32_t n = fiber->capacity; if (n) { Janet *newData = janet_malloc(sizeof(Janet) * n); if (NULL == newData) { JANET_OUT_OF_MEMORY; } memcpy(newData, fiber->data, fiber->capacity * sizeof(Janet)); janet_free(fiber->data); fiber->data = newData; } } #endif /* Ensure that the fiber has enough extra capacity */ void janet_fiber_setcapacity(JanetFiber *fiber, int32_t n) { int32_t old_size = fiber->capacity; int32_t diff = n - old_size; Janet *newData = janet_realloc(fiber->data, sizeof(Janet) * n); if (NULL == newData) { JANET_OUT_OF_MEMORY; } fiber->data = newData; fiber->capacity = n; janet_vm.next_collection += sizeof(Janet) * diff; } /* Grow fiber if needed */ static void janet_fiber_grow(JanetFiber *fiber, int32_t needed) { int32_t cap = needed > (INT32_MAX / 2) ? INT32_MAX : 2 * needed; janet_fiber_setcapacity(fiber, cap); } /* Push a value on the next stack frame */ void janet_fiber_push(JanetFiber *fiber, Janet x) { if (fiber->stacktop == INT32_MAX) janet_panic("stack overflow"); if (fiber->stacktop >= fiber->capacity) { janet_fiber_grow(fiber, fiber->stacktop); } fiber->data[fiber->stacktop++] = x; } /* Push 2 values on the next stack frame */ void janet_fiber_push2(JanetFiber *fiber, Janet x, Janet y) { if (fiber->stacktop >= INT32_MAX - 1) janet_panic("stack overflow"); int32_t newtop = fiber->stacktop + 2; if (newtop > fiber->capacity) { janet_fiber_grow(fiber, newtop); } fiber->data[fiber->stacktop] = x; fiber->data[fiber->stacktop + 1] = y; fiber->stacktop = newtop; } /* Push 3 values on the next stack frame */ void janet_fiber_push3(JanetFiber *fiber, Janet x, Janet y, Janet z) { if (fiber->stacktop >= INT32_MAX - 2) janet_panic("stack overflow"); int32_t newtop = fiber->stacktop + 3; if (newtop > fiber->capacity) { janet_fiber_grow(fiber, newtop); } fiber->data[fiber->stacktop] = x; fiber->data[fiber->stacktop + 1] = y; fiber->data[fiber->stacktop + 2] = z; fiber->stacktop = newtop; } /* Push an array on the next stack frame */ void janet_fiber_pushn(JanetFiber *fiber, const Janet *arr, int32_t n) { if (fiber->stacktop > INT32_MAX - n) janet_panic("stack overflow"); int32_t newtop = fiber->stacktop + n; if (newtop > fiber->capacity) { janet_fiber_grow(fiber, newtop); } safe_memcpy(fiber->data + fiber->stacktop, arr, n * sizeof(Janet)); fiber->stacktop = newtop; } /* Create a struct with n values. If n is odd, the last value is ignored. */ static Janet make_struct_n(const Janet *args, int32_t n) { int32_t i = 0; JanetKV *st = janet_struct_begin(n & (~1)); for (; i < n; i += 2) { janet_struct_put(st, args[i], args[i + 1]); } return janet_wrap_struct(janet_struct_end(st)); } /* Push a stack frame to a fiber */ int janet_fiber_funcframe(JanetFiber *fiber, JanetFunction *func) { JanetStackFrame *newframe; int32_t i; int32_t oldtop = fiber->stacktop; int32_t oldframe = fiber->frame; int32_t nextframe = fiber->stackstart; int32_t nextstacktop = nextframe + func->def->slotcount + JANET_FRAME_SIZE; int32_t next_arity = fiber->stacktop - fiber->stackstart; /* Check strict arity before messing with state */ if (next_arity < func->def->min_arity) return 1; if (next_arity > func->def->max_arity) return 1; if (fiber->capacity < nextstacktop) { janet_fiber_setcapacity(fiber, 2 * nextstacktop); #ifdef JANET_DEBUG } else { janet_fiber_refresh_memory(fiber); #endif } /* Nil unset stack arguments (Needed for gc correctness) */ for (i = fiber->stacktop; i < nextstacktop; ++i) { fiber->data[i] = janet_wrap_nil(); } /* Set up the next frame */ fiber->frame = nextframe; fiber->stacktop = fiber->stackstart = nextstacktop; newframe = janet_fiber_frame(fiber); newframe->prevframe = oldframe; newframe->pc = func->def->bytecode; newframe->func = func; newframe->env = NULL; newframe->flags = 0; /* Check varargs */ if (func->def->flags & JANET_FUNCDEF_FLAG_VARARG) { int32_t tuplehead = fiber->frame + func->def->arity; int st = func->def->flags & JANET_FUNCDEF_FLAG_STRUCTARG; if (tuplehead >= oldtop) { fiber->data[tuplehead] = st ? make_struct_n(NULL, 0) : janet_wrap_tuple(janet_tuple_n(NULL, 0)); } else { fiber->data[tuplehead] = st ? make_struct_n( fiber->data + tuplehead, oldtop - tuplehead) : janet_wrap_tuple(janet_tuple_n( fiber->data + tuplehead, oldtop - tuplehead)); } } /* Good return */ return 0; } /* If a frame has a closure environment, detach it from * the stack and have it keep its own values */ static void janet_env_detach(JanetFuncEnv *env) { /* Check for closure environment */ if (env) { janet_env_valid(env); int32_t len = env->length; size_t s = sizeof(Janet) * (size_t) len; Janet *vmem = janet_malloc(s); janet_vm.next_collection += (uint32_t) s; if (NULL == vmem) { JANET_OUT_OF_MEMORY; } Janet *values = env->as.fiber->data + env->offset; safe_memcpy(vmem, values, s); uint32_t *bitset = janet_stack_frame(values)->func->def->closure_bitset; if (bitset) { /* Clear unneeded references in closure environment */ for (int32_t i = 0; i < len; i += 32) { uint32_t mask = ~(bitset[i >> 5]); int32_t maxj = i + 32 > len ? len : i + 32; for (int32_t j = i; j < maxj; j++) { if (mask & 1) vmem[j] = janet_wrap_nil(); mask >>= 1; } } } env->offset = 0; env->as.values = vmem; } } /* Validate potentially untrusted func env (unmarshalled envs are difficult to verify) */ int janet_env_valid(JanetFuncEnv *env) { if (env->offset < 0) { int32_t real_offset = -(env->offset); JanetFiber *fiber = env->as.fiber; int32_t i = fiber->frame; while (i > 0) { JanetStackFrame *frame = (JanetStackFrame *)(fiber->data + i - JANET_FRAME_SIZE); if (real_offset == i && frame->env == env && frame->func && frame->func->def->slotcount == env->length) { env->offset = real_offset; return 1; } i = frame->prevframe; } /* Invalid, set to empty off-stack variant. */ env->offset = 0; env->length = 0; env->as.values = NULL; return 0; } else { return 1; } } /* Detach a fiber from the env if the target fiber has stopped mutating */ void janet_env_maybe_detach(JanetFuncEnv *env) { /* Check for detachable closure envs */ janet_env_valid(env); if (env->offset > 0) { JanetFiberStatus s = janet_fiber_status(env->as.fiber); int isFinished = s == JANET_STATUS_DEAD || s == JANET_STATUS_ERROR || s == JANET_STATUS_USER0 || s == JANET_STATUS_USER1 || s == JANET_STATUS_USER2 || s == JANET_STATUS_USER3 || s == JANET_STATUS_USER4; if (isFinished) { janet_env_detach(env); } } } /* Create a tail frame for a function */ int janet_fiber_funcframe_tail(JanetFiber *fiber, JanetFunction *func) { int32_t i; int32_t nextframetop = fiber->frame + func->def->slotcount; int32_t nextstacktop = nextframetop + JANET_FRAME_SIZE; int32_t next_arity = fiber->stacktop - fiber->stackstart; int32_t stacksize; /* Check strict arity before messing with state */ if (next_arity < func->def->min_arity) return 1; if (next_arity > func->def->max_arity) return 1; if (fiber->capacity < nextstacktop) { janet_fiber_setcapacity(fiber, 2 * nextstacktop); #ifdef JANET_DEBUG } else { janet_fiber_refresh_memory(fiber); #endif } Janet *stack = fiber->data + fiber->frame; Janet *args = fiber->data + fiber->stackstart; /* Detach old function */ if (NULL != janet_fiber_frame(fiber)->func) janet_env_detach(janet_fiber_frame(fiber)->env); janet_fiber_frame(fiber)->env = NULL; /* Check varargs */ if (func->def->flags & JANET_FUNCDEF_FLAG_VARARG) { int32_t tuplehead = fiber->stackstart + func->def->arity; int st = func->def->flags & JANET_FUNCDEF_FLAG_STRUCTARG; if (tuplehead >= fiber->stacktop) { if (tuplehead >= fiber->capacity) janet_fiber_setcapacity(fiber, 2 * (tuplehead + 1)); for (i = fiber->stacktop; i < tuplehead; ++i) fiber->data[i] = janet_wrap_nil(); fiber->data[tuplehead] = st ? make_struct_n(NULL, 0) : janet_wrap_tuple(janet_tuple_n(NULL, 0)); } else { fiber->data[tuplehead] = st ? make_struct_n( fiber->data + tuplehead, fiber->stacktop - tuplehead) : janet_wrap_tuple(janet_tuple_n( fiber->data + tuplehead, fiber->stacktop - tuplehead)); } stacksize = tuplehead - fiber->stackstart + 1; } else { stacksize = fiber->stacktop - fiber->stackstart; } if (stacksize) memmove(stack, args, stacksize * sizeof(Janet)); /* Nil unset locals (Needed for functional correctness) */ for (i = fiber->frame + stacksize; i < nextframetop; ++i) fiber->data[i] = janet_wrap_nil(); /* Set stack stuff */ fiber->stacktop = fiber->stackstart = nextstacktop; /* Set frame stuff */ janet_fiber_frame(fiber)->func = func; janet_fiber_frame(fiber)->pc = func->def->bytecode; janet_fiber_frame(fiber)->flags |= JANET_STACKFRAME_TAILCALL; /* Good return */ return 0; } /* Push a stack frame to a fiber for a c function */ void janet_fiber_cframe(JanetFiber *fiber, JanetCFunction cfun) { JanetStackFrame *newframe; int32_t oldframe = fiber->frame; int32_t nextframe = fiber->stackstart; int32_t nextstacktop = fiber->stacktop + JANET_FRAME_SIZE; if (fiber->capacity < nextstacktop) { janet_fiber_setcapacity(fiber, 2 * nextstacktop); #ifdef JANET_DEBUG } else { janet_fiber_refresh_memory(fiber); #endif } /* Set the next frame */ fiber->frame = nextframe; fiber->stacktop = fiber->stackstart = nextstacktop; newframe = janet_fiber_frame(fiber); /* Set up the new frame */ newframe->prevframe = oldframe; newframe->pc = (uint32_t *) cfun; newframe->func = NULL; newframe->env = NULL; newframe->flags = 0; } /* Pop a stack frame from the fiber. */ void janet_fiber_popframe(JanetFiber *fiber) { JanetStackFrame *frame = janet_fiber_frame(fiber); if (fiber->frame == 0) return; /* Clean up the frame (detach environments) */ if (NULL != frame->func) janet_env_detach(frame->env); /* Shrink stack */ fiber->stacktop = fiber->stackstart = fiber->frame; fiber->frame = frame->prevframe; } JanetFiberStatus janet_fiber_status(JanetFiber *f) { return ((f)->flags & JANET_FIBER_STATUS_MASK) >> JANET_FIBER_STATUS_OFFSET; } JanetFiber *janet_current_fiber(void) { return janet_vm.fiber; } JanetFiber *janet_root_fiber(void) { return janet_vm.root_fiber; } /* CFuns */ JANET_CORE_FN(cfun_fiber_getenv, "(fiber/getenv fiber)", "Gets the environment for a fiber. Returns nil if no such table is " "set yet.") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); return fiber->env ? janet_wrap_table(fiber->env) : janet_wrap_nil(); } JANET_CORE_FN(cfun_fiber_setenv, "(fiber/setenv fiber table)", "Sets the environment table for a fiber. Set to nil to remove the current " "environment.") { janet_fixarity(argc, 2); JanetFiber *fiber = janet_getfiber(argv, 0); if (janet_checktype(argv[1], JANET_NIL)) { fiber->env = NULL; } else { fiber->env = janet_gettable(argv, 1); } return argv[0]; } JANET_CORE_FN(cfun_fiber_new, "(fiber/new func &opt sigmask env)", "Create a new fiber with function body func. Can optionally " "take a set of signals `sigmask` to capture from child fibers, " "and an environment table `env`. The mask is specified as a keyword where each character " "is used to indicate a signal to block. If the ev module is enabled, and " "this fiber is used as an argument to `ev/go`, these \"blocked\" signals " "will result in messages being sent to the supervisor channel. " "The default sigmask is :y. " "For example,\n\n" " (fiber/new myfun :e123)\n\n" "blocks error signals and user signals 1, 2 and 3. The signals are " "as follows:\n\n" "* :a - block all signals\n" "* :d - block debug signals\n" "* :e - block error signals\n" "* :t - block termination signals: error + user[0-4]\n" "* :u - block user signals\n" "* :y - block yield signals\n" "* :w - block await signals (user9)\n" "* :r - block interrupt signals (user8)\n" "* :0-9 - block a specific user signal\n\n" "The sigmask argument also can take environment flags. If any mutually " "exclusive flags are present, the last flag takes precedence.\n\n" "* :i - inherit the environment from the current fiber\n" "* :p - the environment table's prototype is the current environment table") { janet_arity(argc, 1, 3); JanetFunction *func = janet_getfunction(argv, 0); JanetFiber *fiber; if (func->def->min_arity > 1) { janet_panicf("fiber function must accept 0 or 1 arguments"); } fiber = janet_fiber(func, 64, func->def->min_arity, NULL); janet_assert(fiber != NULL, "bad fiber arity check"); if (argc == 3 && !janet_checktype(argv[2], JANET_NIL)) { fiber->env = janet_gettable(argv, 2); } if (argc >= 2) { int32_t i; JanetByteView view = janet_getbytes(argv, 1); fiber->flags = JANET_FIBER_RESUME_NO_USEVAL | JANET_FIBER_RESUME_NO_SKIP; janet_fiber_set_status(fiber, JANET_STATUS_NEW); for (i = 0; i < view.len; i++) { if (view.bytes[i] >= '0' && view.bytes[i] <= '9') { fiber->flags |= JANET_FIBER_MASK_USERN(view.bytes[i] - '0'); } else { switch (view.bytes[i]) { default: janet_panicf("invalid flag %c, expected a, t, d, e, u, y, w, r, i, or p", view.bytes[i]); break; case 'a': fiber->flags |= JANET_FIBER_MASK_DEBUG | JANET_FIBER_MASK_ERROR | JANET_FIBER_MASK_USER | JANET_FIBER_MASK_YIELD; break; case 't': fiber->flags |= JANET_FIBER_MASK_ERROR | JANET_FIBER_MASK_USER0 | JANET_FIBER_MASK_USER1 | JANET_FIBER_MASK_USER2 | JANET_FIBER_MASK_USER3 | JANET_FIBER_MASK_USER4; break; case 'd': fiber->flags |= JANET_FIBER_MASK_DEBUG; break; case 'e': fiber->flags |= JANET_FIBER_MASK_ERROR; break; case 'u': fiber->flags |= JANET_FIBER_MASK_USER; break; case 'y': fiber->flags |= JANET_FIBER_MASK_YIELD; break; case 'w': fiber->flags |= JANET_FIBER_MASK_USER9; break; case 'r': fiber->flags |= JANET_FIBER_MASK_USER8; break; case 'i': if (!janet_vm.fiber->env) { janet_vm.fiber->env = janet_table(0); } fiber->env = janet_vm.fiber->env; break; case 'p': if (!janet_vm.fiber->env) { janet_vm.fiber->env = janet_table(0); } fiber->env = janet_table(0); fiber->env->proto = janet_vm.fiber->env; break; } } } } return janet_wrap_fiber(fiber); } JANET_CORE_FN(cfun_fiber_status, "(fiber/status fib)", "Get the status of a fiber. The status will be one of:\n\n" "* :dead - the fiber has finished\n" "* :error - the fiber has errored out\n" "* :debug - the fiber is suspended in debug mode\n" "* :pending - the fiber has been yielded\n" "* :user(0-7) - the fiber is suspended by a user signal\n" "* :interrupted - the fiber was interrupted\n" "* :suspended - the fiber is waiting to be resumed by the scheduler\n" "* :alive - the fiber is currently running and cannot be resumed\n" "* :new - the fiber has just been created and not yet run") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); uint32_t s = janet_fiber_status(fiber); return janet_ckeywordv(janet_status_names[s]); } JANET_CORE_FN(cfun_fiber_current, "(fiber/current)", "Returns the currently running fiber.") { (void) argv; janet_fixarity(argc, 0); return janet_wrap_fiber(janet_vm.fiber); } JANET_CORE_FN(cfun_fiber_root, "(fiber/root)", "Returns the current root fiber. The root fiber is the oldest " "ancestor that does not have a parent. Note that a root fiber " "is also a task fiber.") { (void) argv; janet_fixarity(argc, 0); return janet_wrap_fiber(janet_vm.root_fiber); } JANET_CORE_FN(cfun_fiber_maxstack, "(fiber/maxstack fib)", "Gets the maximum stack size in janet values allowed for a fiber. While memory for " "the fiber's stack is not allocated up front, the fiber will not allocated more " "than this amount and will throw a stack-overflow error if more memory is needed. ") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); return janet_wrap_integer(fiber->maxstack); } JANET_CORE_FN(cfun_fiber_setmaxstack, "(fiber/setmaxstack fib maxstack)", "Sets the maximum stack size in janet values for a fiber. By default, the " "maximum stack size is usually 8192.") { janet_fixarity(argc, 2); JanetFiber *fiber = janet_getfiber(argv, 0); int32_t maxs = janet_getinteger(argv, 1); if (maxs < 0) { janet_panic("expected positive integer"); } fiber->maxstack = maxs; return argv[0]; } int janet_fiber_can_resume(JanetFiber *fiber) { JanetFiberStatus s = janet_fiber_status(fiber); int isFinished = s == JANET_STATUS_DEAD || s == JANET_STATUS_ERROR || s == JANET_STATUS_USER0 || s == JANET_STATUS_USER1 || s == JANET_STATUS_USER2 || s == JANET_STATUS_USER3 || s == JANET_STATUS_USER4; return !isFinished; } JANET_CORE_FN(cfun_fiber_can_resume, "(fiber/can-resume? fiber)", "Check if a fiber is finished and cannot be resumed.") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); return janet_wrap_boolean(janet_fiber_can_resume(fiber)); } JANET_CORE_FN(cfun_fiber_last_value, "(fiber/last-value fiber)", "Get the last value returned or signaled from the fiber.") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); return fiber->last_value; } /* Module entry point */ void janet_lib_fiber(JanetTable *env) { JanetRegExt fiber_cfuns[] = { JANET_CORE_REG("fiber/new", cfun_fiber_new), JANET_CORE_REG("fiber/status", cfun_fiber_status), JANET_CORE_REG("fiber/root", cfun_fiber_root), JANET_CORE_REG("fiber/current", cfun_fiber_current), JANET_CORE_REG("fiber/maxstack", cfun_fiber_maxstack), JANET_CORE_REG("fiber/setmaxstack", cfun_fiber_setmaxstack), JANET_CORE_REG("fiber/getenv", cfun_fiber_getenv), JANET_CORE_REG("fiber/setenv", cfun_fiber_setenv), JANET_CORE_REG("fiber/can-resume?", cfun_fiber_can_resume), JANET_CORE_REG("fiber/last-value", cfun_fiber_last_value), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, fiber_cfuns); } janet-1.41.2/src/core/fiber.h000066400000000000000000000065631514534607600157040ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_FIBER_H_defined #define JANET_FIBER_H_defined #ifndef JANET_AMALG #include #endif /* Fiber signal masks. */ #define JANET_FIBER_MASK_ERROR 2 #define JANET_FIBER_MASK_DEBUG 4 #define JANET_FIBER_MASK_YIELD 8 #define JANET_FIBER_MASK_USER0 (16 << 0) #define JANET_FIBER_MASK_USER1 (16 << 1) #define JANET_FIBER_MASK_USER2 (16 << 2) #define JANET_FIBER_MASK_USER3 (16 << 3) #define JANET_FIBER_MASK_USER4 (16 << 4) #define JANET_FIBER_MASK_USER5 (16 << 5) #define JANET_FIBER_MASK_USER6 (16 << 6) #define JANET_FIBER_MASK_USER7 (16 << 7) #define JANET_FIBER_MASK_USER8 (16 << 8) #define JANET_FIBER_MASK_USER9 (16 << 9) #define JANET_FIBER_MASK_USERN(N) (16 << (N)) #define JANET_FIBER_MASK_USER 0x3FF0 #define JANET_FIBER_STATUS_MASK 0x3F0000 #define JANET_FIBER_RESUME_SIGNAL 0x400000 #define JANET_FIBER_STATUS_OFFSET 16 #define JANET_FIBER_BREAKPOINT 0x1000000 #define JANET_FIBER_RESUME_NO_USEVAL 0x2000000 #define JANET_FIBER_RESUME_NO_SKIP 0x4000000 #define JANET_FIBER_DID_LONGJUMP 0x8000000 #define JANET_FIBER_FLAG_MASK 0xF000000 #define JANET_FIBER_EV_FLAG_CANCELED 0x10000 #define JANET_FIBER_EV_FLAG_SUSPENDED 0x20000 #define JANET_FIBER_FLAG_ROOT 0x40000 #define JANET_FIBER_EV_FLAG_IN_FLIGHT 0x1 /* used only on windows, should otherwise be unset */ #define janet_fiber_set_status(f, s) do {\ (f)->flags &= ~JANET_FIBER_STATUS_MASK;\ (f)->flags |= (s) << JANET_FIBER_STATUS_OFFSET;\ } while (0) #define janet_stack_frame(s) ((JanetStackFrame *)((s) - JANET_FRAME_SIZE)) #define janet_fiber_frame(f) janet_stack_frame((f)->data + (f)->frame) void janet_fiber_setcapacity(JanetFiber *fiber, int32_t n); void janet_fiber_push(JanetFiber *fiber, Janet x); void janet_fiber_push2(JanetFiber *fiber, Janet x, Janet y); void janet_fiber_push3(JanetFiber *fiber, Janet x, Janet y, Janet z); void janet_fiber_pushn(JanetFiber *fiber, const Janet *arr, int32_t n); int janet_fiber_funcframe(JanetFiber *fiber, JanetFunction *func); int janet_fiber_funcframe_tail(JanetFiber *fiber, JanetFunction *func); void janet_fiber_cframe(JanetFiber *fiber, JanetCFunction cfun); void janet_fiber_popframe(JanetFiber *fiber); void janet_env_maybe_detach(JanetFuncEnv *env); int janet_env_valid(JanetFuncEnv *env); #ifdef JANET_EV void janet_fiber_did_resume(JanetFiber *fiber); #endif #endif janet-1.41.2/src/core/filewatch.c000066400000000000000000000657341514534607600165630ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "util.h" #endif #ifdef JANET_EV #ifdef JANET_FILEWATCH #ifdef JANET_LINUX #include #include #endif #ifdef JANET_WINDOWS #include #endif typedef struct { const char *name; uint32_t flag; } JanetWatchFlagName; typedef struct { #ifndef JANET_WINDOWS JanetStream *stream; #endif JanetTable *watch_descriptors; JanetChannel *channel; uint32_t default_flags; int is_watching; } JanetWatcher; #ifdef JANET_LINUX #include #include static const JanetWatchFlagName watcher_flags_linux[] = { {"access", IN_ACCESS}, {"all", IN_ALL_EVENTS}, {"attrib", IN_ATTRIB}, {"close-nowrite", IN_CLOSE_NOWRITE}, {"close-write", IN_CLOSE_WRITE}, {"create", IN_CREATE}, {"delete", IN_DELETE}, {"delete-self", IN_DELETE_SELF}, {"ignored", IN_IGNORED}, {"modify", IN_MODIFY}, {"move-self", IN_MOVE_SELF}, {"moved-from", IN_MOVED_FROM}, {"moved-to", IN_MOVED_TO}, {"open", IN_OPEN}, {"q-overflow", IN_Q_OVERFLOW}, {"unmount", IN_UNMOUNT}, }; static uint32_t decode_watch_flags(const Janet *options, int32_t n) { uint32_t flags = 0; for (int32_t i = 0; i < n; i++) { if (!(janet_checktype(options[i], JANET_KEYWORD))) { janet_panicf("expected keyword, got %v", options[i]); } JanetKeyword keyw = janet_unwrap_keyword(options[i]); const JanetWatchFlagName *result = janet_strbinsearch(watcher_flags_linux, sizeof(watcher_flags_linux) / sizeof(JanetWatchFlagName), sizeof(JanetWatchFlagName), keyw); if (!result) { janet_panicf("unknown inotify flag %v", options[i]); } flags |= result->flag; } return flags; } static void janet_watcher_init(JanetWatcher *watcher, JanetChannel *channel, uint32_t default_flags) { int fd; do { fd = inotify_init1(IN_NONBLOCK | IN_CLOEXEC); } while (fd == -1 && errno == EINTR); if (fd == -1) { janet_panicv(janet_ev_lasterr()); } watcher->watch_descriptors = janet_table(0); watcher->channel = channel; watcher->default_flags = default_flags; watcher->is_watching = 0; watcher->stream = janet_stream(fd, JANET_STREAM_READABLE, NULL); } static void janet_watcher_add(JanetWatcher *watcher, const char *path, uint32_t flags) { if (watcher->stream == NULL) janet_panic("watcher closed"); int result; do { result = inotify_add_watch(watcher->stream->handle, path, flags); } while (result == -1 && errno == EINTR); if (result == -1) { janet_panicv(janet_ev_lasterr()); } Janet name = janet_cstringv(path); Janet wd = janet_wrap_integer(result); janet_table_put(watcher->watch_descriptors, name, wd); janet_table_put(watcher->watch_descriptors, wd, name); } static void janet_watcher_remove(JanetWatcher *watcher, const char *path) { if (watcher->stream == NULL) janet_panic("watcher closed"); Janet check = janet_table_get(watcher->watch_descriptors, janet_cstringv(path)); janet_assert(janet_checktype(check, JANET_NUMBER), "bad watch descriptor"); int watch_handle = janet_unwrap_integer(check); int result; do { result = inotify_rm_watch(watcher->stream->handle, watch_handle); } while (result != -1 && errno == EINTR); if (result == -1) { janet_panicv(janet_ev_lasterr()); } } static void watcher_callback_read(JanetFiber *fiber, JanetAsyncEvent event) { JanetStream *stream = fiber->ev_stream; JanetWatcher *watcher = *((JanetWatcher **) fiber->ev_state); char buf[1024]; switch (event) { default: break; case JANET_ASYNC_EVENT_MARK: janet_mark(janet_wrap_abstract(watcher)); break; case JANET_ASYNC_EVENT_CLOSE: janet_schedule(fiber, janet_wrap_nil()); janet_async_end(fiber); break; case JANET_ASYNC_EVENT_ERR: { janet_schedule(fiber, janet_wrap_nil()); janet_async_end(fiber); break; } read_more: case JANET_ASYNC_EVENT_HUP: case JANET_ASYNC_EVENT_INIT: case JANET_ASYNC_EVENT_READ: { Janet name = janet_wrap_nil(); /* Assumption - read will never return partial events * * From documentation: * * The behavior when the buffer given to read(2) is too small to * return information about the next event depends on the kernel * version: before Linux 2.6.21, read(2) returns 0; since Linux * 2.6.21, read(2) fails with the error EINVAL. Specifying a buffer * of size * * sizeof(struct inotify_event) + NAME_MAX + 1 * * will be sufficient to read at least one event. */ ssize_t nread; do { nread = read(stream->handle, buf, sizeof(buf)); } while (nread == -1 && errno == EINTR); /* Check for errors - special case errors that can just be waited on to fix */ if (nread == -1) { if (errno == EAGAIN || errno == EWOULDBLOCK) { break; } janet_cancel(fiber, janet_ev_lasterr()); fiber->ev_state = NULL; janet_async_end(fiber); break; } if (nread < (ssize_t) sizeof(struct inotify_event)) break; /* Iterate through all events read from the buffer */ char *cursor = buf; while (cursor < buf + nread) { struct inotify_event inevent; memcpy(&inevent, cursor, sizeof(inevent)); cursor += sizeof(inevent); /* Read path of inevent */ if (inevent.len) { name = janet_cstringv(cursor); cursor += inevent.len; } /* Got an event */ Janet path = janet_table_get(watcher->watch_descriptors, janet_wrap_integer(inevent.wd)); JanetKV *event = janet_struct_begin(6); janet_struct_put(event, janet_ckeywordv("wd"), janet_wrap_integer(inevent.wd)); janet_struct_put(event, janet_ckeywordv("wd-path"), path); if (janet_checktype(name, JANET_NIL)) { /* We were watching a file directly, so path is the full path. Split into dirname / basename */ JanetString spath = janet_unwrap_string(path); const uint8_t *cursor = spath + janet_string_length(spath); const uint8_t *cursor_end = cursor; while (cursor > spath && cursor[0] != '/') { cursor--; } if (cursor == spath) { janet_struct_put(event, janet_ckeywordv("dir-name"), path); janet_struct_put(event, janet_ckeywordv("file-name"), name); } else { janet_struct_put(event, janet_ckeywordv("dir-name"), janet_wrap_string(janet_string(spath, (cursor - spath)))); janet_struct_put(event, janet_ckeywordv("file-name"), janet_wrap_string(janet_string(cursor + 1, (cursor_end - cursor - 1)))); } } else { janet_struct_put(event, janet_ckeywordv("dir-name"), path); janet_struct_put(event, janet_ckeywordv("file-name"), name); } janet_struct_put(event, janet_ckeywordv("cookie"), janet_wrap_integer(inevent.cookie)); Janet etype = janet_ckeywordv("type"); const JanetWatchFlagName *wfn_end = watcher_flags_linux + sizeof(watcher_flags_linux) / sizeof(watcher_flags_linux[0]); for (const JanetWatchFlagName *wfn = watcher_flags_linux; wfn < wfn_end; wfn++) { if ((inevent.mask & wfn->flag) == wfn->flag) janet_struct_put(event, etype, janet_ckeywordv(wfn->name)); } Janet eventv = janet_wrap_struct(janet_struct_end(event)); janet_channel_give(watcher->channel, eventv); } /* Read some more if possible */ goto read_more; } break; } } static void janet_watcher_listen(JanetWatcher *watcher) { if (watcher->is_watching) janet_panic("already watching"); watcher->is_watching = 1; JanetFunction *thunk = janet_thunk_delay(janet_wrap_nil()); JanetFiber *fiber = janet_fiber(thunk, 64, 0, NULL); JanetWatcher **state = janet_malloc(sizeof(JanetWatcher *)); /* Gross */ *state = watcher; janet_async_start_fiber(fiber, watcher->stream, JANET_ASYNC_LISTEN_READ, watcher_callback_read, state); janet_gcroot(janet_wrap_abstract(watcher)); } static void janet_watcher_unlisten(JanetWatcher *watcher) { if (!watcher->is_watching) return; watcher->is_watching = 0; janet_stream_close(watcher->stream); janet_gcunroot(janet_wrap_abstract(watcher)); } #elif JANET_WINDOWS #define WATCHFLAG_RECURSIVE 0x100000u static const JanetWatchFlagName watcher_flags_windows[] = { { "all", FILE_NOTIFY_CHANGE_ATTRIBUTES | FILE_NOTIFY_CHANGE_CREATION | FILE_NOTIFY_CHANGE_DIR_NAME | FILE_NOTIFY_CHANGE_FILE_NAME | FILE_NOTIFY_CHANGE_LAST_ACCESS | FILE_NOTIFY_CHANGE_LAST_WRITE | FILE_NOTIFY_CHANGE_SECURITY | FILE_NOTIFY_CHANGE_SIZE | WATCHFLAG_RECURSIVE }, {"attributes", FILE_NOTIFY_CHANGE_ATTRIBUTES}, {"creation", FILE_NOTIFY_CHANGE_CREATION}, {"dir-name", FILE_NOTIFY_CHANGE_DIR_NAME}, {"file-name", FILE_NOTIFY_CHANGE_FILE_NAME}, {"last-access", FILE_NOTIFY_CHANGE_LAST_ACCESS}, {"last-write", FILE_NOTIFY_CHANGE_LAST_WRITE}, {"recursive", WATCHFLAG_RECURSIVE}, {"security", FILE_NOTIFY_CHANGE_SECURITY}, {"size", FILE_NOTIFY_CHANGE_SIZE}, }; static uint32_t decode_watch_flags(const Janet *options, int32_t n) { uint32_t flags = 0; for (int32_t i = 0; i < n; i++) { if (!(janet_checktype(options[i], JANET_KEYWORD))) { janet_panicf("expected keyword, got %v", options[i]); } JanetKeyword keyw = janet_unwrap_keyword(options[i]); const JanetWatchFlagName *result = janet_strbinsearch(watcher_flags_windows, sizeof(watcher_flags_windows) / sizeof(JanetWatchFlagName), sizeof(JanetWatchFlagName), keyw); if (!result) { janet_panicf("unknown windows filewatch flag %v", options[i]); } flags |= result->flag; } return flags; } static void janet_watcher_init(JanetWatcher *watcher, JanetChannel *channel, uint32_t default_flags) { watcher->watch_descriptors = janet_table(0); watcher->channel = channel; watcher->default_flags = default_flags; watcher->is_watching = 0; } /* Since the file info padding includes embedded file names, we want to include more space for data. * We also need to handle manually calculating changes if path names are too long, but ideally just avoid * that scenario as much as possible */ #define FILE_INFO_PADDING (4096 * 4) typedef struct { OVERLAPPED overlapped; JanetStream *stream; JanetWatcher *watcher; JanetFiber *fiber; JanetString dir_path; uint32_t flags; uint64_t buf[FILE_INFO_PADDING / sizeof(uint64_t)]; /* Ensure alignment */ } OverlappedWatch; #define NotifyChange FILE_NOTIFY_INFORMATION static void read_dir_changes(OverlappedWatch *ow) { BOOL result = ReadDirectoryChangesW(ow->stream->handle, (NotifyChange *) ow->buf, FILE_INFO_PADDING, (ow->flags & WATCHFLAG_RECURSIVE) ? TRUE : FALSE, ow->flags & ~WATCHFLAG_RECURSIVE, NULL, (OVERLAPPED *) ow, NULL); if (!result) { janet_panicv(janet_ev_lasterr()); } } static const char *watcher_actions_windows[] = { "unknown", "added", "removed", "modified", "renamed-old", "renamed-new", }; static void watcher_callback_read(JanetFiber *fiber, JanetAsyncEvent event) { OverlappedWatch *ow = (OverlappedWatch *) fiber->ev_state; JanetWatcher *watcher = ow->watcher; switch (event) { default: break; case JANET_ASYNC_EVENT_INIT: janet_async_in_flight(fiber); break; case JANET_ASYNC_EVENT_MARK: janet_mark(janet_wrap_abstract(ow->stream)); janet_mark(janet_wrap_fiber(ow->fiber)); janet_mark(janet_wrap_abstract(watcher)); janet_mark(janet_wrap_string(ow->dir_path)); break; case JANET_ASYNC_EVENT_CLOSE: janet_table_remove(ow->watcher->watch_descriptors, janet_wrap_string(ow->dir_path)); break; case JANET_ASYNC_EVENT_ERR: case JANET_ASYNC_EVENT_FAILED: janet_stream_close(ow->stream); break; case JANET_ASYNC_EVENT_COMPLETE: { if (!watcher->is_watching) { janet_stream_close(ow->stream); break; } NotifyChange *fni = (NotifyChange *) ow->buf; while (1) { /* Got an event */ /* Extract name */ Janet filename; if (fni->FileNameLength) { int32_t nbytes = (int32_t) WideCharToMultiByte(CP_UTF8, 0, fni->FileName, fni->FileNameLength / sizeof(wchar_t), NULL, 0, NULL, NULL); janet_assert(nbytes, "bad utf8 path"); uint8_t *into = janet_string_begin(nbytes); WideCharToMultiByte(CP_UTF8, 0, fni->FileName, fni->FileNameLength / sizeof(wchar_t), (char *) into, nbytes, NULL, NULL); filename = janet_wrap_string(janet_string_end(into)); } else { filename = janet_cstringv(""); } JanetKV *event = janet_struct_begin(3); janet_struct_put(event, janet_ckeywordv("type"), janet_ckeywordv(watcher_actions_windows[fni->Action])); janet_struct_put(event, janet_ckeywordv("file-name"), filename); janet_struct_put(event, janet_ckeywordv("dir-name"), janet_wrap_string(ow->dir_path)); Janet eventv = janet_wrap_struct(janet_struct_end(event)); janet_channel_give(watcher->channel, eventv); /* Next event */ if (!fni->NextEntryOffset) break; fni = (NotifyChange *)((char *)fni + fni->NextEntryOffset); } /* Make another call to read directory changes */ read_dir_changes(ow); janet_async_in_flight(fiber); } break; } } static void start_listening_ow(OverlappedWatch *ow) { read_dir_changes(ow); JanetStream *stream = ow->stream; JanetFunction *thunk = janet_thunk_delay(janet_wrap_nil()); JanetFiber *fiber = janet_fiber(thunk, 64, 0, NULL); fiber->supervisor_channel = janet_root_fiber()->supervisor_channel; ow->fiber = fiber; janet_async_start_fiber(fiber, stream, JANET_ASYNC_LISTEN_READ, watcher_callback_read, ow); } static void janet_watcher_add(JanetWatcher *watcher, const char *path, uint32_t flags) { HANDLE handle = CreateFileA(path, FILE_LIST_DIRECTORY | GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, OPEN_EXISTING, FILE_FLAG_OVERLAPPED | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (handle == INVALID_HANDLE_VALUE) { janet_panicv(janet_ev_lasterr()); } JanetStream *stream = janet_stream(handle, JANET_STREAM_READABLE, NULL); OverlappedWatch *ow = janet_malloc(sizeof(OverlappedWatch)); memset(ow, 0, sizeof(OverlappedWatch)); ow->stream = stream; ow->dir_path = janet_cstring(path); ow->fiber = NULL; Janet pathv = janet_wrap_string(ow->dir_path); ow->flags = flags | watcher->default_flags; ow->watcher = watcher; ow->overlapped.hEvent = CreateEvent(NULL, FALSE, 0, NULL); /* Do we need this */ Janet streamv = janet_wrap_pointer(ow); janet_table_put(watcher->watch_descriptors, pathv, streamv); if (watcher->is_watching) { start_listening_ow(ow); } } static void janet_watcher_remove(JanetWatcher *watcher, const char *path) { Janet pathv = janet_cstringv(path); Janet streamv = janet_table_get(watcher->watch_descriptors, pathv); if (janet_checktype(streamv, JANET_NIL)) { janet_panicf("path %v is not being watched", pathv); } janet_table_remove(watcher->watch_descriptors, pathv); OverlappedWatch *ow = janet_unwrap_pointer(streamv); janet_stream_close(ow->stream); } static void janet_watcher_listen(JanetWatcher *watcher) { if (watcher->is_watching) janet_panic("already watching"); watcher->is_watching = 1; for (int32_t i = 0; i < watcher->watch_descriptors->capacity; i++) { const JanetKV *kv = watcher->watch_descriptors->data + i; if (!janet_checktype(kv->value, JANET_POINTER)) continue; OverlappedWatch *ow = janet_unwrap_pointer(kv->value); start_listening_ow(ow); } janet_gcroot(janet_wrap_abstract(watcher)); } static void janet_watcher_unlisten(JanetWatcher *watcher) { if (!watcher->is_watching) return; watcher->is_watching = 0; for (int32_t i = 0; i < watcher->watch_descriptors->capacity; i++) { const JanetKV *kv = watcher->watch_descriptors->data + i; if (!janet_checktype(kv->value, JANET_POINTER)) continue; OverlappedWatch *ow = janet_unwrap_pointer(kv->value); janet_stream_close(ow->stream); } janet_table_clear(watcher->watch_descriptors); janet_gcunroot(janet_wrap_abstract(watcher)); } #else /* Default implementation */ static uint32_t decode_watch_flags(const Janet *options, int32_t n) { (void) options; (void) n; return 0; } static void janet_watcher_init(JanetWatcher *watcher, JanetChannel *channel, uint32_t default_flags) { (void) watcher; (void) channel; (void) default_flags; janet_panic("filewatch not supported on this platform"); } static void janet_watcher_add(JanetWatcher *watcher, const char *path, uint32_t flags) { (void) watcher; (void) flags; (void) path; janet_panic("filewatch not supported on this platform"); } static void janet_watcher_remove(JanetWatcher *watcher, const char *path) { (void) watcher; (void) path; janet_panic("filewatch not supported on this platform"); } static void janet_watcher_listen(JanetWatcher *watcher) { (void) watcher; janet_panic("filewatch not supported on this platform"); } static void janet_watcher_unlisten(JanetWatcher *watcher) { (void) watcher; janet_panic("filewatch not supported on this platform"); } #endif /* C Functions */ static int janet_filewatch_mark(void *p, size_t s) { JanetWatcher *watcher = (JanetWatcher *) p; (void) s; if (watcher->channel == NULL) return 0; /* Incomplete initialization */ #ifdef JANET_WINDOWS for (int32_t i = 0; i < watcher->watch_descriptors->capacity; i++) { const JanetKV *kv = watcher->watch_descriptors->data + i; if (!janet_checktype(kv->value, JANET_POINTER)) continue; OverlappedWatch *ow = janet_unwrap_pointer(kv->value); janet_mark(janet_wrap_fiber(ow->fiber)); janet_mark(janet_wrap_abstract(ow->stream)); janet_mark(janet_wrap_string(ow->dir_path)); } #else janet_mark(janet_wrap_abstract(watcher->stream)); #endif janet_mark(janet_wrap_abstract(watcher->channel)); janet_mark(janet_wrap_table(watcher->watch_descriptors)); return 0; } static const JanetAbstractType janet_filewatch_at = { "filewatch/watcher", NULL, janet_filewatch_mark, JANET_ATEND_GCMARK }; JANET_CORE_FN(cfun_filewatch_make, "(filewatch/new channel & default-flags)", "Create a new filewatcher that will give events to a channel channel. See `filewatch/add` for available flags.\n\n" "When an event is triggered by the filewatcher, a struct containing information will be given to channel as with `ev/give`. " "The contents of the channel depend on the OS, but will contain some common keys:\n\n" "* `:type` -- the type of the event that was raised.\n\n" "* `:file-name` -- the base file name of the file that triggered the event.\n\n" "* `:dir-name` -- the directory name of the file that triggered the event.\n\n" "Events also will contain keys specific to the host OS.\n\n" "Windows has no extra properties on events.\n\n" "Linux has the following extra properties on events:\n\n" "* `:wd` -- the integer key returned by `filewatch/add` for the path that triggered this.\n\n" "* `:wd-path` -- the string path for watched directory of file. For files, will be the same as `:file-name`, and for directories, will be the same as `:dir-name`.\n\n" "* `:cookie` -- a randomized integer used to associate related events, such as :moved-from and :moved-to events.\n\n" "") { janet_sandbox_assert(JANET_SANDBOX_FS_READ); janet_arity(argc, 1, -1); JanetChannel *channel = janet_getchannel(argv, 0); JanetWatcher *watcher = janet_abstract(&janet_filewatch_at, sizeof(JanetWatcher)); uint32_t default_flags = decode_watch_flags(argv + 1, argc - 1); janet_watcher_init(watcher, channel, default_flags); return janet_wrap_abstract(watcher); } JANET_CORE_FN(cfun_filewatch_add, "(filewatch/add watcher path flag & more-flags)", "Add a path to the watcher. Available flags depend on the current OS, and are as follows:\n\n" "Windows/MINGW (flags correspond to `FILE_NOTIFY_CHANGE_*` flags in win32 documentation):\n\n" "* `:all` - trigger an event for all of the below triggers.\n\n" "* `:attributes` - `FILE_NOTIFY_CHANGE_ATTRIBUTES`\n\n" "* `:creation` - `FILE_NOTIFY_CHANGE_CREATION`\n\n" "* `:dir-name` - `FILE_NOTIFY_CHANGE_DIR_NAME`\n\n" "* `:last-access` - `FILE_NOTIFY_CHANGE_LAST_ACCESS`\n\n" "* `:last-write` - `FILE_NOTIFY_CHANGE_LAST_WRITE`\n\n" "* `:security` - `FILE_NOTIFY_CHANGE_SECURITY`\n\n" "* `:size` - `FILE_NOTIFY_CHANGE_SIZE`\n\n" "* `:recursive` - watch subdirectories recursively\n\n" "Linux (flags correspond to `IN_*` flags from ):\n\n" "* `:access` - `IN_ACCESS`\n\n" "* `:all` - `IN_ALL_EVENTS`\n\n" "* `:attrib` - `IN_ATTRIB`\n\n" "* `:close-nowrite` - `IN_CLOSE_NOWRITE`\n\n" "* `:close-write` - `IN_CLOSE_WRITE`\n\n" "* `:create` - `IN_CREATE`\n\n" "* `:delete` - `IN_DELETE`\n\n" "* `:delete-self` - `IN_DELETE_SELF`\n\n" "* `:ignored` - `IN_IGNORED`\n\n" "* `:modify` - `IN_MODIFY`\n\n" "* `:move-self` - `IN_MOVE_SELF`\n\n" "* `:moved-from` - `IN_MOVED_FROM`\n\n" "* `:moved-to` - `IN_MOVED_TO`\n\n" "* `:open` - `IN_OPEN`\n\n" "* `:q-overflow` - `IN_Q_OVERFLOW`\n\n" "* `:unmount` - `IN_UNMOUNT`\n\n\n" "On Windows, events will have the following possible types:\n\n" "* `:unknown`\n\n" "* `:added`\n\n" "* `:removed`\n\n" "* `:modified`\n\n" "* `:renamed-old`\n\n" "* `:renamed-new`\n\n" "On Linux, events will have a `:type` corresponding to the possible flags, excluding `:all`.\n" "") { janet_arity(argc, 2, -1); JanetWatcher *watcher = janet_getabstract(argv, 0, &janet_filewatch_at); const char *path = janet_getcstring(argv, 1); uint32_t flags = watcher->default_flags | decode_watch_flags(argv + 2, argc - 2); janet_watcher_add(watcher, path, flags); return argv[0]; } JANET_CORE_FN(cfun_filewatch_remove, "(filewatch/remove watcher path)", "Remove a path from the watcher.") { janet_fixarity(argc, 2); JanetWatcher *watcher = janet_getabstract(argv, 0, &janet_filewatch_at); const char *path = janet_getcstring(argv, 1); janet_watcher_remove(watcher, path); return argv[0]; } JANET_CORE_FN(cfun_filewatch_listen, "(filewatch/listen watcher)", "Listen for changes in the watcher.") { janet_fixarity(argc, 1); JanetWatcher *watcher = janet_getabstract(argv, 0, &janet_filewatch_at); janet_watcher_listen(watcher); return janet_wrap_nil(); } JANET_CORE_FN(cfun_filewatch_unlisten, "(filewatch/unlisten watcher)", "Stop listening for changes on a given watcher.") { janet_fixarity(argc, 1); JanetWatcher *watcher = janet_getabstract(argv, 0, &janet_filewatch_at); janet_watcher_unlisten(watcher); return janet_wrap_nil(); } /* Module entry point */ void janet_lib_filewatch(JanetTable *env) { JanetRegExt cfuns[] = { JANET_CORE_REG("filewatch/new", cfun_filewatch_make), JANET_CORE_REG("filewatch/add", cfun_filewatch_add), JANET_CORE_REG("filewatch/remove", cfun_filewatch_remove), JANET_CORE_REG("filewatch/listen", cfun_filewatch_listen), JANET_CORE_REG("filewatch/unlisten", cfun_filewatch_unlisten), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, cfuns); } #endif #endif janet-1.41.2/src/core/gc.c000066400000000000000000000620701514534607600151740ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "state.h" #include "symcache.h" #include "gc.h" #include "util.h" #include "fiber.h" #include "vector.h" #endif /* Helpers for marking the various gc types */ static void janet_mark_funcenv(JanetFuncEnv *env); static void janet_mark_funcdef(JanetFuncDef *def); static void janet_mark_function(JanetFunction *func); static void janet_mark_array(JanetArray *array); static void janet_mark_table(JanetTable *table); static void janet_mark_struct(const JanetKV *st); static void janet_mark_tuple(const Janet *tuple); static void janet_mark_buffer(JanetBuffer *buffer); static void janet_mark_string(const uint8_t *str); static void janet_mark_fiber(JanetFiber *fiber); static void janet_mark_abstract(void *adata); /* Local state that is only temporary for gc */ static JANET_THREAD_LOCAL uint32_t depth = JANET_RECURSION_GUARD; static JANET_THREAD_LOCAL size_t orig_rootcount; /* Hint to the GC that we may need to collect */ void janet_gcpressure(size_t s) { janet_vm.next_collection += s; } /* Mark a value */ void janet_mark(Janet x) { if (depth) { depth--; switch (janet_type(x)) { default: break; case JANET_STRING: case JANET_KEYWORD: case JANET_SYMBOL: janet_mark_string(janet_unwrap_string(x)); break; case JANET_FUNCTION: janet_mark_function(janet_unwrap_function(x)); break; case JANET_ARRAY: janet_mark_array(janet_unwrap_array(x)); break; case JANET_TABLE: janet_mark_table(janet_unwrap_table(x)); break; case JANET_STRUCT: janet_mark_struct(janet_unwrap_struct(x)); break; case JANET_TUPLE: janet_mark_tuple(janet_unwrap_tuple(x)); break; case JANET_BUFFER: janet_mark_buffer(janet_unwrap_buffer(x)); break; case JANET_FIBER: janet_mark_fiber(janet_unwrap_fiber(x)); break; case JANET_ABSTRACT: janet_mark_abstract(janet_unwrap_abstract(x)); break; } depth++; } else { janet_gcroot(x); } } static void janet_mark_string(const uint8_t *str) { janet_gc_mark(janet_string_head(str)); } static void janet_mark_buffer(JanetBuffer *buffer) { janet_gc_mark(buffer); } static void janet_mark_abstract(void *adata) { #ifdef JANET_EV /* Check if abstract type is a threaded abstract type. If it is, marking means * updating the threaded_abstract table. */ if ((janet_abstract_head(adata)->gc.flags & JANET_MEM_TYPEBITS) == JANET_MEMORY_THREADED_ABSTRACT) { janet_table_put(&janet_vm.threaded_abstracts, janet_wrap_abstract(adata), janet_wrap_true()); return; } #endif if (janet_gc_reachable(janet_abstract_head(adata))) return; janet_gc_mark(janet_abstract_head(adata)); if (janet_abstract_head(adata)->type->gcmark) { janet_abstract_head(adata)->type->gcmark(adata, janet_abstract_size(adata)); } } /* Mark a bunch of items in memory */ static void janet_mark_many(const Janet *values, int32_t n) { if (values == NULL) return; const Janet *end = values + n; while (values < end) { janet_mark(*values); values += 1; } } /* Mark a bunch of key values items in memory */ static void janet_mark_keys(const JanetKV *kvs, int32_t n) { const JanetKV *end = kvs + n; while (kvs < end) { janet_mark(kvs->key); kvs++; } } /* Mark a bunch of key values items in memory */ static void janet_mark_values(const JanetKV *kvs, int32_t n) { const JanetKV *end = kvs + n; while (kvs < end) { janet_mark(kvs->value); kvs++; } } /* Mark a bunch of key values items in memory */ static void janet_mark_kvs(const JanetKV *kvs, int32_t n) { const JanetKV *end = kvs + n; while (kvs < end) { janet_mark(kvs->key); janet_mark(kvs->value); kvs++; } } static void janet_mark_array(JanetArray *array) { if (janet_gc_reachable(array)) return; janet_gc_mark(array); if (janet_gc_type((JanetGCObject *) array) == JANET_MEMORY_ARRAY) { janet_mark_many(array->data, array->count); } } static void janet_mark_table(JanetTable *table) { recur: /* Manual tail recursion */ if (janet_gc_reachable(table)) return; janet_gc_mark(table); enum JanetMemoryType memtype = janet_gc_type(table); if (memtype == JANET_MEMORY_TABLE_WEAKK) { janet_mark_values(table->data, table->capacity); } else if (memtype == JANET_MEMORY_TABLE_WEAKV) { janet_mark_keys(table->data, table->capacity); } else if (memtype == JANET_MEMORY_TABLE) { janet_mark_kvs(table->data, table->capacity); } /* do nothing for JANET_MEMORY_TABLE_WEAKKV */ if (table->proto) { table = table->proto; goto recur; } } static void janet_mark_struct(const JanetKV *st) { recur: if (janet_gc_reachable(janet_struct_head(st))) return; janet_gc_mark(janet_struct_head(st)); janet_mark_kvs(st, janet_struct_capacity(st)); st = janet_struct_proto(st); if (st) goto recur; } static void janet_mark_tuple(const Janet *tuple) { if (janet_gc_reachable(janet_tuple_head(tuple))) return; janet_gc_mark(janet_tuple_head(tuple)); janet_mark_many(tuple, janet_tuple_length(tuple)); } /* Helper to mark function environments */ static void janet_mark_funcenv(JanetFuncEnv *env) { if (janet_gc_reachable(env)) return; janet_gc_mark(env); /* If closure env references a dead fiber, we can just copy out the stack frame we need so * we don't need to keep around the whole dead fiber. */ janet_env_maybe_detach(env); if (env->offset > 0) { /* On stack */ janet_mark_fiber(env->as.fiber); } else { /* Not on stack */ janet_mark_many(env->as.values, env->length); } } /* GC helper to mark a FuncDef */ static void janet_mark_funcdef(JanetFuncDef *def) { int32_t i; if (janet_gc_reachable(def)) return; janet_gc_mark(def); janet_mark_many(def->constants, def->constants_length); for (i = 0; i < def->defs_length; ++i) { janet_mark_funcdef(def->defs[i]); } if (def->source) janet_mark_string(def->source); if (def->name) janet_mark_string(def->name); if (def->symbolmap) { for (int i = 0; i < def->symbolmap_length; i++) { janet_mark_string(def->symbolmap[i].symbol); } } } static void janet_mark_function(JanetFunction *func) { int32_t i; int32_t numenvs; if (janet_gc_reachable(func)) return; janet_gc_mark(func); if (NULL != func->def) { /* this should always be true, except if function is only partially constructed */ numenvs = func->def->environments_length; for (i = 0; i < numenvs; ++i) { janet_mark_funcenv(func->envs[i]); } janet_mark_funcdef(func->def); } } static void janet_mark_fiber(JanetFiber *fiber) { int32_t i, j; JanetStackFrame *frame; recur: if (janet_gc_reachable(fiber)) return; janet_gc_mark(fiber); janet_mark(fiber->last_value); /* Mark values on the argument stack */ janet_mark_many(fiber->data + fiber->stackstart, fiber->stacktop - fiber->stackstart); i = fiber->frame; j = fiber->stackstart - JANET_FRAME_SIZE; while (i > 0) { frame = (JanetStackFrame *)(fiber->data + i - JANET_FRAME_SIZE); if (NULL != frame->func) janet_mark_function(frame->func); if (NULL != frame->env) janet_mark_funcenv(frame->env); /* Mark all values in the stack frame */ janet_mark_many(fiber->data + i, j - i); j = i - JANET_FRAME_SIZE; i = frame->prevframe; } if (fiber->env) janet_mark_table(fiber->env); #ifdef JANET_EV if (fiber->supervisor_channel) { janet_mark_abstract(fiber->supervisor_channel); } if (fiber->ev_stream) { janet_mark_abstract(fiber->ev_stream); } if (fiber->ev_callback) { fiber->ev_callback(fiber, JANET_ASYNC_EVENT_MARK); } #endif /* Explicit tail recursion */ if (fiber->child) { fiber = fiber->child; goto recur; } } /* Deinitialize a block of memory */ static void janet_deinit_block(JanetGCObject *mem) { switch (mem->flags & JANET_MEM_TYPEBITS) { default: case JANET_MEMORY_FUNCTION: break; /* Do nothing for non gc types */ case JANET_MEMORY_SYMBOL: janet_symbol_deinit(((JanetStringHead *) mem)->data); break; case JANET_MEMORY_ARRAY: case JANET_MEMORY_ARRAY_WEAK: janet_free(((JanetArray *) mem)->data); break; case JANET_MEMORY_TABLE: case JANET_MEMORY_TABLE_WEAKK: case JANET_MEMORY_TABLE_WEAKV: case JANET_MEMORY_TABLE_WEAKKV: janet_free(((JanetTable *) mem)->data); break; case JANET_MEMORY_FIBER: { JanetFiber *f = (JanetFiber *)mem; #ifdef JANET_EV if (f->ev_state && !(f->flags & JANET_FIBER_EV_FLAG_IN_FLIGHT)) { janet_ev_dec_refcount(); janet_free(f->ev_state); } #endif janet_free(f->data); } break; case JANET_MEMORY_BUFFER: janet_buffer_deinit((JanetBuffer *) mem); break; case JANET_MEMORY_ABSTRACT: { JanetAbstractHead *head = (JanetAbstractHead *)mem; if (head->type->gcperthread) { janet_assert(!head->type->gcperthread(head->data, head->size), "per-thread finalizer failed"); } if (head->type->gc) { janet_assert(!head->type->gc(head->data, head->size), "finalizer failed"); } } break; case JANET_MEMORY_FUNCENV: { JanetFuncEnv *env = (JanetFuncEnv *)mem; if (0 == env->offset) janet_free(env->as.values); } break; case JANET_MEMORY_FUNCDEF: { JanetFuncDef *def = (JanetFuncDef *)mem; /* TODO - get this all with one alloc and one free */ janet_free(def->defs); janet_free(def->environments); janet_free(def->constants); janet_free(def->bytecode); janet_free(def->sourcemap); janet_free(def->closure_bitset); janet_free(def->symbolmap); } break; } } /* Check that a value x has been visited in the mark phase */ static int janet_check_liveref(Janet x) { switch (janet_type(x)) { default: return 1; case JANET_ARRAY: case JANET_TABLE: case JANET_FUNCTION: case JANET_BUFFER: case JANET_FIBER: return janet_gc_reachable(janet_unwrap_pointer(x)); case JANET_STRING: case JANET_SYMBOL: case JANET_KEYWORD: return janet_gc_reachable(janet_string_head(janet_unwrap_string(x))); case JANET_ABSTRACT: return janet_gc_reachable(janet_abstract_head(janet_unwrap_abstract(x))); case JANET_TUPLE: return janet_gc_reachable(janet_tuple_head(janet_unwrap_tuple(x))); case JANET_STRUCT: return janet_gc_reachable(janet_struct_head(janet_unwrap_struct(x))); } } /* Iterate over all allocated memory, and free memory that is not * marked as reachable. Flip the gc color flag for next sweep. */ void janet_sweep() { JanetGCObject *previous = NULL; JanetGCObject *current = janet_vm.weak_blocks; JanetGCObject *next; /* Sweep weak heap to drop weak refs */ while (NULL != current) { next = current->data.next; if (current->flags & (JANET_MEM_REACHABLE | JANET_MEM_DISABLED)) { /* Check for dead references */ enum JanetMemoryType type = janet_gc_type(current); if (type == JANET_MEMORY_ARRAY_WEAK) { JanetArray *array = (JanetArray *) current; for (uint32_t i = 0; i < (uint32_t) array->count; i++) { if (!janet_check_liveref(array->data[i])) { array->data[i] = janet_wrap_nil(); } } } else { JanetTable *table = (JanetTable *) current; int check_values = (type == JANET_MEMORY_TABLE_WEAKV) || (type == JANET_MEMORY_TABLE_WEAKKV); int check_keys = (type == JANET_MEMORY_TABLE_WEAKK) || (type == JANET_MEMORY_TABLE_WEAKKV); JanetKV *end = table->data + table->capacity; JanetKV *kvs = table->data; while (kvs < end) { int drop = 0; if (check_keys && !janet_check_liveref(kvs->key)) drop = 1; if (check_values && !janet_check_liveref(kvs->value)) drop = 1; if (drop) { /* Inlined from janet_table_remove without search */ table->count--; table->deleted++; kvs->key = janet_wrap_nil(); kvs->value = janet_wrap_false(); } kvs++; } } } current = next; } /* Sweep weak heap to free blocks */ previous = NULL; current = janet_vm.weak_blocks; while (NULL != current) { next = current->data.next; if (current->flags & (JANET_MEM_REACHABLE | JANET_MEM_DISABLED)) { previous = current; current->flags &= ~JANET_MEM_REACHABLE; } else { janet_vm.block_count--; janet_deinit_block(current); if (NULL != previous) { previous->data.next = next; } else { janet_vm.weak_blocks = next; } janet_free(current); } current = next; } /* Sweep main heap to free blocks */ previous = NULL; current = janet_vm.blocks; while (NULL != current) { next = current->data.next; if (current->flags & (JANET_MEM_REACHABLE | JANET_MEM_DISABLED)) { previous = current; current->flags &= ~JANET_MEM_REACHABLE; } else { janet_vm.block_count--; janet_deinit_block(current); if (NULL != previous) { previous->data.next = next; } else { janet_vm.blocks = next; } janet_free(current); } current = next; } #ifdef JANET_EV /* Sweep threaded abstract types for references to decrement */ JanetKV *items = janet_vm.threaded_abstracts.data; for (int32_t i = 0; i < janet_vm.threaded_abstracts.capacity; i++) { if (janet_checktype(items[i].key, JANET_ABSTRACT)) { /* If item was not visited during the mark phase, then this * abstract type isn't present in the heap and needs its refcount * decremented, and shouuld be removed from table. If the refcount is * then 0, the item will be collected. This ensures that only one interpreter * will clean up the threaded abstract. */ /* If not visited... */ if (!janet_truthy(items[i].value)) { void *abst = janet_unwrap_abstract(items[i].key); JanetAbstractHead *head = janet_abstract_head(abst); if (head->type->gcperthread) { janet_assert(!head->type->gcperthread(head->data, head->size), "per-thread finalizer failed"); } janet_abstract_decref_maybe_free(abst); /* Mark as tombstone in place */ items[i].key = janet_wrap_nil(); items[i].value = janet_wrap_false(); janet_vm.threaded_abstracts.deleted++; janet_vm.threaded_abstracts.count--; } /* Reset for next sweep */ items[i].value = janet_wrap_false(); } } #endif } /* Allocate some memory that is tracked for garbage collection */ void *janet_gcalloc(enum JanetMemoryType type, size_t size) { JanetGCObject *mem; /* Make sure everything is inited */ janet_assert(NULL != janet_vm.cache, "please initialize janet before use"); mem = janet_malloc(size); /* Check for bad malloc */ if (NULL == mem) { JANET_OUT_OF_MEMORY; } /* Configure block */ mem->flags = type; /* Prepend block to heap list */ janet_vm.next_collection += size; if (type < JANET_MEMORY_TABLE_WEAKK) { /* normal heap */ mem->data.next = janet_vm.blocks; janet_vm.blocks = mem; } else { /* weak heap */ mem->data.next = janet_vm.weak_blocks; janet_vm.weak_blocks = mem; } janet_vm.block_count++; return (void *)mem; } static void free_one_scratch(JanetScratch *s) { if (NULL != s->finalize) { s->finalize((char *) s->mem); } janet_free(s); } /* Free all allocated scratch memory */ static void janet_free_all_scratch(void) { for (size_t i = 0; i < janet_vm.scratch_len; i++) { free_one_scratch(janet_vm.scratch_mem[i]); } janet_vm.scratch_len = 0; } static JanetScratch *janet_mem2scratch(void *mem) { JanetScratch *s = (JanetScratch *)mem; return s - 1; } /* Run garbage collection */ void janet_collect(void) { uint32_t i; if (janet_vm.gc_suspend) return; depth = JANET_RECURSION_GUARD; janet_vm.gc_mark_phase = 1; /* Try to prevent many major collections back to back. * A full collection will take O(janet_vm.block_count) time. * If we have a large heap, make sure our interval is not too * small so we won't make many collections over it. This is just a * heuristic for automatically changing the gc interval */ if (janet_vm.block_count * 8 > janet_vm.gc_interval) { janet_vm.gc_interval = janet_vm.block_count * sizeof(JanetGCObject); } orig_rootcount = janet_vm.root_count; #ifdef JANET_EV janet_ev_mark(); #endif janet_mark_fiber(janet_vm.root_fiber); for (i = 0; i < orig_rootcount; i++) janet_mark(janet_vm.roots[i]); while (orig_rootcount < janet_vm.root_count) { Janet x = janet_vm.roots[--janet_vm.root_count]; janet_mark(x); } janet_vm.gc_mark_phase = 0; janet_sweep(); janet_vm.next_collection = 0; janet_free_all_scratch(); } /* Add a root value to the GC. This prevents the GC from removing a value * and all of its children. If gcroot is called on a value n times, unroot * must also be called n times to remove it as a gc root. */ void janet_gcroot(Janet root) { size_t newcount = janet_vm.root_count + 1; if (newcount > janet_vm.root_capacity) { size_t newcap = 2 * newcount; janet_vm.roots = janet_realloc(janet_vm.roots, sizeof(Janet) * newcap); if (NULL == janet_vm.roots) { JANET_OUT_OF_MEMORY; } janet_vm.root_capacity = newcap; } janet_vm.roots[janet_vm.root_count] = root; janet_vm.root_count = newcount; } /* Identity equality for GC purposes */ static int janet_gc_idequals(Janet lhs, Janet rhs) { if (janet_type(lhs) != janet_type(rhs)) return 0; switch (janet_type(lhs)) { case JANET_BOOLEAN: case JANET_NIL: case JANET_NUMBER: /* These values don't really matter to the gc so returning 1 all the time is fine. */ return 1; default: return janet_unwrap_pointer(lhs) == janet_unwrap_pointer(rhs); } } /* Remove a root value from the GC. This allows the gc to potentially reclaim * a value and all its children. */ int janet_gcunroot(Janet root) { Janet *vtop = janet_vm.roots + janet_vm.root_count; /* Search from top to bottom as access is most likely LIFO */ for (Janet *v = janet_vm.roots; v < vtop; v++) { if (janet_gc_idequals(root, *v)) { *v = janet_vm.roots[--janet_vm.root_count]; return 1; } } return 0; } /* Remove a root value from the GC. This sets the effective reference count to 0. */ int janet_gcunrootall(Janet root) { Janet *vtop = janet_vm.roots + janet_vm.root_count; int ret = 0; /* Search from top to bottom as access is most likely LIFO */ for (Janet *v = janet_vm.roots; v < vtop; v++) { if (janet_gc_idequals(root, *v)) { *v = janet_vm.roots[--janet_vm.root_count]; vtop--; ret = 1; } } return ret; } /* Free all allocated memory */ void janet_clear_memory(void) { #ifdef JANET_EV JanetKV *items = janet_vm.threaded_abstracts.data; for (int32_t i = 0; i < janet_vm.threaded_abstracts.capacity; i++) { if (janet_checktype(items[i].key, JANET_ABSTRACT)) { void *abst = janet_unwrap_abstract(items[i].key); JanetAbstractHead *head = janet_abstract_head(abst); if (head->type->gcperthread) { janet_assert(!head->type->gcperthread(head->data, head->size), "per-thread finalizer failed"); } janet_abstract_decref_maybe_free(abst); } } #endif JanetGCObject *current = janet_vm.blocks; while (NULL != current) { janet_deinit_block(current); JanetGCObject *next = current->data.next; janet_free(current); current = next; } janet_vm.blocks = NULL; janet_free_all_scratch(); janet_free(janet_vm.scratch_mem); } /* Primitives for suspending GC. */ int janet_gclock(void) { return janet_vm.gc_suspend++; } void janet_gcunlock(int handle) { janet_vm.gc_suspend = handle; } /* Scratch memory API * Scratch memory allocations do not need to be free (but optionally can be), and will be automatically cleaned * up in the next call to janet_collect. */ void *janet_smalloc(size_t size) { JanetScratch *s = janet_malloc(sizeof(JanetScratch) + size); if (NULL == s) { JANET_OUT_OF_MEMORY; } s->finalize = NULL; if (janet_vm.scratch_len == janet_vm.scratch_cap) { size_t newcap = 2 * janet_vm.scratch_cap + 2; JanetScratch **newmem = (JanetScratch **) janet_realloc(janet_vm.scratch_mem, newcap * sizeof(JanetScratch)); if (NULL == newmem) { JANET_OUT_OF_MEMORY; } janet_vm.scratch_cap = newcap; janet_vm.scratch_mem = newmem; } janet_vm.scratch_mem[janet_vm.scratch_len++] = s; return (char *)(s->mem); } void *janet_scalloc(size_t nmemb, size_t size) { if (nmemb && size > SIZE_MAX / nmemb) { JANET_OUT_OF_MEMORY; } size_t n = nmemb * size; void *p = janet_smalloc(n); memset(p, 0, n); return p; } void *janet_srealloc(void *mem, size_t size) { if (NULL == mem) return janet_smalloc(size); JanetScratch *s = janet_mem2scratch(mem); if (janet_vm.scratch_len) { for (size_t i = janet_vm.scratch_len - 1; ; i--) { if (janet_vm.scratch_mem[i] == s) { JanetScratch *news = janet_realloc(s, size + sizeof(JanetScratch)); if (NULL == news) { JANET_OUT_OF_MEMORY; } janet_vm.scratch_mem[i] = news; return (char *)(news->mem); } if (i == 0) break; } } JANET_EXIT("invalid janet_srealloc"); } void janet_sfinalizer(void *mem, JanetScratchFinalizer finalizer) { JanetScratch *s = janet_mem2scratch(mem); s->finalize = finalizer; } void janet_sfree(void *mem) { if (NULL == mem) return; JanetScratch *s = janet_mem2scratch(mem); if (janet_vm.scratch_len) { for (size_t i = janet_vm.scratch_len - 1; ; i--) { if (janet_vm.scratch_mem[i] == s) { janet_vm.scratch_mem[i] = janet_vm.scratch_mem[--janet_vm.scratch_len]; free_one_scratch(s); return; } if (i == 0) break; } } JANET_EXIT("invalid janet_sfree"); } janet-1.41.2/src/core/gc.h000066400000000000000000000050271514534607600152000ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_GC_H #define JANET_GC_H #ifndef JANET_AMALG #include "features.h" #include #endif /* The metadata header associated with an allocated block of memory */ #define janet_gc_header(mem) ((JanetGCObject *)(mem)) #define JANET_MEM_TYPEBITS 0xFF #define JANET_MEM_REACHABLE 0x100 #define JANET_MEM_DISABLED 0x200 #define janet_gc_settype(m, t) ((janet_gc_header(m)->flags |= (0xFF & (t)))) #define janet_gc_type(m) (janet_gc_header(m)->flags & 0xFF) #define janet_gc_mark(m) (janet_gc_header(m)->flags |= JANET_MEM_REACHABLE) #define janet_gc_reachable(m) (janet_gc_header(m)->flags & JANET_MEM_REACHABLE) /* Memory types for the GC. Different from JanetType to include funcenv and funcdef. */ enum JanetMemoryType { JANET_MEMORY_NONE, JANET_MEMORY_STRING, JANET_MEMORY_SYMBOL, JANET_MEMORY_ARRAY, JANET_MEMORY_TUPLE, JANET_MEMORY_TABLE, JANET_MEMORY_STRUCT, JANET_MEMORY_FIBER, JANET_MEMORY_BUFFER, JANET_MEMORY_FUNCTION, JANET_MEMORY_ABSTRACT, JANET_MEMORY_FUNCENV, JANET_MEMORY_FUNCDEF, JANET_MEMORY_THREADED_ABSTRACT, JANET_MEMORY_TABLE_WEAKK, JANET_MEMORY_TABLE_WEAKV, JANET_MEMORY_TABLE_WEAKKV, JANET_MEMORY_ARRAY_WEAK }; /* To allocate collectable memory, one must call janet_alloc, initialize the memory, * and then call when janet_enablegc when it is initialized and reachable by the gc (on the JANET stack) */ void *janet_gcalloc(enum JanetMemoryType type, size_t size); #endif janet-1.41.2/src/core/inttypes.c000066400000000000000000000551061514534607600164640ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose & contributors * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "util.h" #endif #include #include #include #include #include /* Conditional compilation */ #ifdef JANET_INT_TYPES #define MAX_INT_IN_DBL 9007199254740992ULL /* 2^53 */ static int it_s64_get(void *p, Janet key, Janet *out); static int it_u64_get(void *p, Janet key, Janet *out); static Janet janet_int64_next(void *p, Janet key); static Janet janet_uint64_next(void *p, Janet key); static int32_t janet_int64_hash(void *p1, size_t size) { (void) size; int32_t *words = p1; return words[0] ^ words[1]; } static int janet_int64_compare(void *p1, void *p2) { int64_t x = *((int64_t *)p1); int64_t y = *((int64_t *)p2); return x == y ? 0 : x < y ? -1 : 1; } static int janet_uint64_compare(void *p1, void *p2) { uint64_t x = *((uint64_t *)p1); uint64_t y = *((uint64_t *)p2); return x == y ? 0 : x < y ? -1 : 1; } static void int64_marshal(void *p, JanetMarshalContext *ctx) { janet_marshal_abstract(ctx, p); janet_marshal_int64(ctx, *((int64_t *)p)); } static void *int64_unmarshal(JanetMarshalContext *ctx) { int64_t *p = janet_unmarshal_abstract(ctx, sizeof(int64_t)); p[0] = janet_unmarshal_int64(ctx); return p; } static void it_s64_tostring(void *p, JanetBuffer *buffer) { char str[32]; snprintf(str, sizeof(str), "%" PRId64, *((int64_t *)p)); janet_buffer_push_cstring(buffer, str); } static void it_u64_tostring(void *p, JanetBuffer *buffer) { char str[32]; snprintf(str, sizeof(str), "%" PRIu64, *((uint64_t *)p)); janet_buffer_push_cstring(buffer, str); } const JanetAbstractType janet_s64_type = { "core/s64", NULL, NULL, it_s64_get, NULL, int64_marshal, int64_unmarshal, it_s64_tostring, janet_int64_compare, janet_int64_hash, janet_int64_next, JANET_ATEND_NEXT }; const JanetAbstractType janet_u64_type = { "core/u64", NULL, NULL, it_u64_get, NULL, int64_marshal, int64_unmarshal, it_u64_tostring, janet_uint64_compare, janet_int64_hash, janet_uint64_next, JANET_ATEND_NEXT }; int64_t janet_unwrap_s64(Janet x) { switch (janet_type(x)) { default: break; case JANET_NUMBER : { double d = janet_unwrap_number(x); if (!janet_checkint64range(d)) break; return (int64_t) d; } case JANET_STRING: { int64_t value; const uint8_t *str = janet_unwrap_string(x); if (janet_scan_int64(str, janet_string_length(str), &value)) return value; break; } case JANET_ABSTRACT: { void *abst = janet_unwrap_abstract(x); if (janet_abstract_type(abst) == &janet_s64_type || (janet_abstract_type(abst) == &janet_u64_type)) return *(int64_t *)abst; break; } } janet_panicf("can not convert %t %q to 64 bit signed integer", x, x); return 0; } uint64_t janet_unwrap_u64(Janet x) { switch (janet_type(x)) { default: break; case JANET_NUMBER : { double d = janet_unwrap_number(x); if (!janet_checkuint64range(d)) break; return (uint64_t) d; } case JANET_STRING: { uint64_t value; const uint8_t *str = janet_unwrap_string(x); if (janet_scan_uint64(str, janet_string_length(str), &value)) return value; break; } case JANET_ABSTRACT: { void *abst = janet_unwrap_abstract(x); if (janet_abstract_type(abst) == &janet_s64_type || (janet_abstract_type(abst) == &janet_u64_type)) return *(uint64_t *)abst; break; } } janet_panicf("can not convert %t %q to a 64 bit unsigned integer", x, x); return 0; } JanetIntType janet_is_int(Janet x) { if (!janet_checktype(x, JANET_ABSTRACT)) return JANET_INT_NONE; const JanetAbstractType *at = janet_abstract_type(janet_unwrap_abstract(x)); return (at == &janet_s64_type) ? JANET_INT_S64 : ((at == &janet_u64_type) ? JANET_INT_U64 : JANET_INT_NONE); } Janet janet_wrap_s64(int64_t x) { int64_t *box = janet_abstract(&janet_s64_type, sizeof(int64_t)); *box = (int64_t)x; return janet_wrap_abstract(box); } Janet janet_wrap_u64(uint64_t x) { uint64_t *box = janet_abstract(&janet_u64_type, sizeof(uint64_t)); *box = (uint64_t)x; return janet_wrap_abstract(box); } JANET_CORE_FN(cfun_it_s64_new, "(int/s64 value)", "Create a boxed signed 64 bit integer from a string value or a number.") { janet_fixarity(argc, 1); return janet_wrap_s64(janet_unwrap_s64(argv[0])); } JANET_CORE_FN(cfun_it_u64_new, "(int/u64 value)", "Create a boxed unsigned 64 bit integer from a string value or a number.") { janet_fixarity(argc, 1); return janet_wrap_u64(janet_unwrap_u64(argv[0])); } JANET_CORE_FN(cfun_to_number, "(int/to-number value)", "Convert an int/u64 or int/s64 to a number. Fails if the number is out of range for an int64.") { janet_fixarity(argc, 1); if (janet_type(argv[0]) == JANET_ABSTRACT) { void *abst = janet_unwrap_abstract(argv[0]); if (janet_abstract_type(abst) == &janet_s64_type) { int64_t value = *((int64_t *)abst); if (value > JANET_INTMAX_INT64) { janet_panicf("cannot convert %q to a number, must be in the range [%q, %q]", argv[0], janet_wrap_number(JANET_INTMIN_DOUBLE), janet_wrap_number(JANET_INTMAX_DOUBLE)); } if (value < -JANET_INTMAX_INT64) { janet_panicf("cannot convert %q to a number, must be in the range [%q, %q]", argv[0], janet_wrap_number(JANET_INTMIN_DOUBLE), janet_wrap_number(JANET_INTMAX_DOUBLE)); } return janet_wrap_number((double)value); } if (janet_abstract_type(abst) == &janet_u64_type) { uint64_t value = *((uint64_t *)abst); if (value > JANET_INTMAX_INT64) { janet_panicf("cannot convert %q to a number, must be in the range [%q, %q]", argv[0], janet_wrap_number(JANET_INTMIN_DOUBLE), janet_wrap_number(JANET_INTMAX_DOUBLE)); } return janet_wrap_number((double)value); } } janet_panicf("expected int/u64 or int/s64, got %q", argv[0]); } JANET_CORE_FN(cfun_to_bytes, "(int/to-bytes value &opt endianness buffer)", "Write the bytes of an `int/s64` or `int/u64` into a buffer.\n" "The `buffer` parameter specifies an existing buffer to write to, if unset a new buffer will be created.\n" "Returns the modified buffer.\n" "The `endianness` parameter indicates the byte order:\n" "- `nil` (unset): system byte order\n" "- `:le`: little-endian, least significant byte first\n" "- `:be`: big-endian, most significant byte first\n") { janet_arity(argc, 1, 3); if (janet_is_int(argv[0]) == JANET_INT_NONE) { janet_panicf("int/to-bytes: expected an int/s64 or int/u64, got %q", argv[0]); } int reverse = 0; if (argc > 1 && !janet_checktype(argv[1], JANET_NIL)) { JanetKeyword endianness_kw = janet_getkeyword(argv, 1); if (!janet_cstrcmp(endianness_kw, "le")) { #if JANET_BIG_ENDIAN reverse = 1; #endif } else if (!janet_cstrcmp(endianness_kw, "be")) { #if JANET_LITTLE_ENDIAN reverse = 1; #endif } else { janet_panicf("int/to-bytes: expected endianness :le, :be or nil, got %v", argv[1]); } } JanetBuffer *buffer = NULL; if (argc > 2 && !janet_checktype(argv[2], JANET_NIL)) { if (!janet_checktype(argv[2], JANET_BUFFER)) { janet_panicf("int/to-bytes: expected buffer or nil, got %q", argv[2]); } buffer = janet_unwrap_buffer(argv[2]); janet_buffer_extra(buffer, 8); } else { buffer = janet_buffer(8); } uint8_t *bytes = janet_unwrap_abstract(argv[0]); if (reverse) { for (int i = 0; i < 8; ++i) { buffer->data[buffer->count + 7 - i] = bytes[i]; } } else { memcpy(buffer->data + buffer->count, bytes, 8); } buffer->count += 8; return janet_wrap_buffer(buffer); } /* * Code to support polymorphic comparison. * int/u64 and int/s64 support a "compare" method that allows * comparison to each other, and to Janet numbers, using the * "compare" "compare<" ... functions. * In the following code explicit casts are sometimes used to help * make it clear when int/float conversions are happening. */ static int compare_double_double(double x, double y) { return (x < y) ? -1 : ((x > y) ? 1 : 0); } static int compare_int64_double(int64_t x, double y) { if (isnan(y)) { return 0; } else if ((y > JANET_INTMIN_DOUBLE) && (y < JANET_INTMAX_DOUBLE)) { double dx = (double) x; return compare_double_double(dx, y); } else if (y > ((double) INT64_MAX)) { return -1; } else if (y < ((double) INT64_MIN)) { return 1; } else { int64_t yi = (int64_t) y; return (x < yi) ? -1 : ((x > yi) ? 1 : 0); } } static int compare_uint64_double(uint64_t x, double y) { if (isnan(y)) { return 0; } else if (y < 0) { return 1; } else if ((y >= 0) && (y < JANET_INTMAX_DOUBLE)) { double dx = (double) x; return compare_double_double(dx, y); } else if (y > ((double) UINT64_MAX)) { return -1; } else { uint64_t yi = (uint64_t) y; return (x < yi) ? -1 : ((x > yi) ? 1 : 0); } } static Janet cfun_it_s64_compare(int32_t argc, Janet *argv) { janet_fixarity(argc, 2); if (janet_is_int(argv[0]) != JANET_INT_S64) { janet_panic("compare method requires int/s64 as first argument"); } int64_t x = janet_unwrap_s64(argv[0]); switch (janet_type(argv[1])) { default: break; case JANET_NUMBER : { double y = janet_unwrap_number(argv[1]); return janet_wrap_number(compare_int64_double(x, y)); } case JANET_ABSTRACT: { void *abst = janet_unwrap_abstract(argv[1]); if (janet_abstract_type(abst) == &janet_s64_type) { int64_t y = *(int64_t *)abst; return janet_wrap_number((x < y) ? -1 : (x > y ? 1 : 0)); } else if (janet_abstract_type(abst) == &janet_u64_type) { uint64_t y = *(uint64_t *)abst; if (x < 0) { return janet_wrap_number(-1); } else if (y > INT64_MAX) { return janet_wrap_number(-1); } else { int64_t y2 = (int64_t) y; return janet_wrap_number((x < y2) ? -1 : (x > y2 ? 1 : 0)); } } break; } } return janet_wrap_nil(); } static Janet cfun_it_u64_compare(int32_t argc, Janet *argv) { janet_fixarity(argc, 2); if (janet_is_int(argv[0]) != JANET_INT_U64) { janet_panic("compare method requires int/u64 as first argument"); } uint64_t x = janet_unwrap_u64(argv[0]); switch (janet_type(argv[1])) { default: break; case JANET_NUMBER : { double y = janet_unwrap_number(argv[1]); return janet_wrap_number(compare_uint64_double(x, y)); } case JANET_ABSTRACT: { void *abst = janet_unwrap_abstract(argv[1]); if (janet_abstract_type(abst) == &janet_u64_type) { uint64_t y = *(uint64_t *)abst; return janet_wrap_number((x < y) ? -1 : (x > y ? 1 : 0)); } else if (janet_abstract_type(abst) == &janet_s64_type) { int64_t y = *(int64_t *)abst; if (y < 0) { return janet_wrap_number(1); } else if (x > INT64_MAX) { return janet_wrap_number(1); } else { int64_t x2 = (int64_t) x; return janet_wrap_number((x2 < y) ? -1 : (x2 > y ? 1 : 0)); } } break; } } return janet_wrap_nil(); } /* * In C, signed arithmetic overflow is undefined behvior * but unsigned arithmetic overflow is twos complement * * Reference: * https://en.cppreference.com/w/cpp/language/ub * http://blog.llvm.org/2011/05/what-every-c-programmer-should-know.html * * This means OPMETHOD & OPMETHODINVERT must always use * unsigned arithmetic internally, regardless of the true type. * This will not affect the end result (property of twos complement). */ #define OPMETHOD(T, type, name, oper) \ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ janet_arity(argc, 2, -1); \ T *box = janet_abstract(&janet_##type##_type, sizeof(T)); \ *box = janet_unwrap_##type(argv[0]); \ for (int32_t i = 1; i < argc; i++) \ /* This avoids undefined behavior. See above for why. */ \ *box = (T) ((uint64_t) (*box)) oper ((uint64_t) janet_unwrap_##type(argv[i])); \ return janet_wrap_abstract(box); \ } \ #define OPMETHODINVERT(T, type, name, oper) \ static Janet cfun_it_##type##_##name##i(int32_t argc, Janet *argv) { \ janet_fixarity(argc, 2); \ T *box = janet_abstract(&janet_##type##_type, sizeof(T)); \ *box = janet_unwrap_##type(argv[1]); \ /* This avoids undefined behavior. See above for why. */ \ *box = (T) ((uint64_t) *box) oper ((uint64_t) janet_unwrap_##type(argv[0])); \ return janet_wrap_abstract(box); \ } \ #define UNARYMETHOD(T, type, name, oper) \ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ janet_fixarity(argc, 1); \ T *box = janet_abstract(&janet_##type##_type, sizeof(T)); \ *box = oper(janet_unwrap_##type(argv[0])); \ return janet_wrap_abstract(box); \ } \ #define DIVZERO(name) DIVZERO_##name #define DIVZERO_div janet_panic("division by zero") #define DIVZERO_rem janet_panic("division by zero") #define DIVZERO_mod return janet_wrap_abstract(box) #define DIVMETHOD(T, type, name, oper) \ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ janet_arity(argc, 2, -1); \ T *box = janet_abstract(&janet_##type##_type, sizeof(T)); \ *box = janet_unwrap_##type(argv[0]); \ for (int32_t i = 1; i < argc; i++) { \ T value = janet_unwrap_##type(argv[i]); \ if (value == 0) DIVZERO(name); \ *box oper##= value; \ } \ return janet_wrap_abstract(box); \ } \ #define DIVMETHODINVERT(T, type, name, oper) \ static Janet cfun_it_##type##_##name##i(int32_t argc, Janet *argv) { \ janet_fixarity(argc, 2); \ T *box = janet_abstract(&janet_##type##_type, sizeof(T)); \ *box = janet_unwrap_##type(argv[1]); \ T value = janet_unwrap_##type(argv[0]); \ if (value == 0) DIVZERO(name); \ *box oper##= value; \ return janet_wrap_abstract(box); \ } \ #define DIVMETHOD_SIGNED(T, type, name, oper) \ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ janet_arity(argc, 2, -1); \ T *box = janet_abstract(&janet_##type##_type, sizeof(T)); \ *box = janet_unwrap_##type(argv[0]); \ for (int32_t i = 1; i < argc; i++) { \ T value = janet_unwrap_##type(argv[i]); \ if (value == 0) DIVZERO(name); \ if ((value == -1) && (*box == INT64_MIN)) janet_panic("INT64_MIN divided by -1"); \ *box oper##= value; \ } \ return janet_wrap_abstract(box); \ } \ #define DIVMETHODINVERT_SIGNED(T, type, name, oper) \ static Janet cfun_it_##type##_##name##i(int32_t argc, Janet *argv) { \ janet_fixarity(argc, 2); \ T *box = janet_abstract(&janet_##type##_type, sizeof(T)); \ *box = janet_unwrap_##type(argv[1]); \ T value = janet_unwrap_##type(argv[0]); \ if (value == 0) DIVZERO(name); \ if ((value == -1) && (*box == INT64_MIN)) janet_panic("INT64_MIN divided by -1"); \ *box oper##= value; \ return janet_wrap_abstract(box); \ } \ static Janet cfun_it_s64_divf(int32_t argc, Janet *argv) { janet_fixarity(argc, 2); int64_t *box = janet_abstract(&janet_s64_type, sizeof(int64_t)); int64_t op1 = janet_unwrap_s64(argv[0]); int64_t op2 = janet_unwrap_s64(argv[1]); if (op2 == 0) janet_panic("division by zero"); int64_t x = op1 / op2; *box = x - (((op1 ^ op2) < 0) && (x * op2 != op1)); return janet_wrap_abstract(box); } static Janet cfun_it_s64_divfi(int32_t argc, Janet *argv) { janet_fixarity(argc, 2); int64_t *box = janet_abstract(&janet_s64_type, sizeof(int64_t)); int64_t op2 = janet_unwrap_s64(argv[0]); int64_t op1 = janet_unwrap_s64(argv[1]); if (op2 == 0) janet_panic("division by zero"); int64_t x = op1 / op2; *box = x - (((op1 ^ op2) < 0) && (x * op2 != op1)); return janet_wrap_abstract(box); } static Janet cfun_it_s64_mod(int32_t argc, Janet *argv) { janet_fixarity(argc, 2); int64_t *box = janet_abstract(&janet_s64_type, sizeof(int64_t)); int64_t op1 = janet_unwrap_s64(argv[0]); int64_t op2 = janet_unwrap_s64(argv[1]); if (op2 == 0) { *box = op1; } else { int64_t x = op1 % op2; *box = (((op1 ^ op2) < 0) && (x != 0)) ? x + op2 : x; } return janet_wrap_abstract(box); } static Janet cfun_it_s64_modi(int32_t argc, Janet *argv) { janet_fixarity(argc, 2); int64_t *box = janet_abstract(&janet_s64_type, sizeof(int64_t)); int64_t op2 = janet_unwrap_s64(argv[0]); int64_t op1 = janet_unwrap_s64(argv[1]); if (op2 == 0) { *box = op1; } else { int64_t x = op1 % op2; *box = (((op1 ^ op2) < 0) && (x != 0)) ? x + op2 : x; } return janet_wrap_abstract(box); } OPMETHOD(int64_t, s64, add, +) OPMETHOD(int64_t, s64, sub, -) OPMETHODINVERT(int64_t, s64, sub, -) OPMETHOD(int64_t, s64, mul, *) DIVMETHOD_SIGNED(int64_t, s64, div, /) DIVMETHOD_SIGNED(int64_t, s64, rem, %) DIVMETHODINVERT_SIGNED(int64_t, s64, div, /) DIVMETHODINVERT_SIGNED(int64_t, s64, rem, %) OPMETHOD(int64_t, s64, and, &) OPMETHOD(int64_t, s64, or, |) OPMETHOD(int64_t, s64, xor, ^) UNARYMETHOD(int64_t, s64, not, ~) OPMETHOD(int64_t, s64, lshift, <<) OPMETHOD(int64_t, s64, rshift, >>) OPMETHOD(uint64_t, u64, add, +) OPMETHOD(uint64_t, u64, sub, -) OPMETHODINVERT(uint64_t, u64, sub, -) OPMETHOD(uint64_t, u64, mul, *) DIVMETHOD(uint64_t, u64, div, /) DIVMETHOD(uint64_t, u64, rem, %) DIVMETHOD(uint64_t, u64, mod, %) DIVMETHODINVERT(uint64_t, u64, div, /) DIVMETHODINVERT(uint64_t, u64, rem, %) DIVMETHODINVERT(uint64_t, u64, mod, %) OPMETHOD(uint64_t, u64, and, &) OPMETHOD(uint64_t, u64, or, |) OPMETHOD(uint64_t, u64, xor, ^) UNARYMETHOD(uint64_t, u64, not, ~) OPMETHOD(uint64_t, u64, lshift, <<) OPMETHOD(uint64_t, u64, rshift, >>) #undef OPMETHOD #undef DIVMETHOD #undef DIVMETHOD_SIGNED #undef COMPMETHOD static JanetMethod it_s64_methods[] = { {"+", cfun_it_s64_add}, {"r+", cfun_it_s64_add}, {"-", cfun_it_s64_sub}, {"r-", cfun_it_s64_subi}, {"*", cfun_it_s64_mul}, {"r*", cfun_it_s64_mul}, {"/", cfun_it_s64_div}, {"r/", cfun_it_s64_divi}, {"div", cfun_it_s64_divf}, {"rdiv", cfun_it_s64_divfi}, {"mod", cfun_it_s64_mod}, {"rmod", cfun_it_s64_modi}, {"%", cfun_it_s64_rem}, {"r%", cfun_it_s64_remi}, {"&", cfun_it_s64_and}, {"r&", cfun_it_s64_and}, {"|", cfun_it_s64_or}, {"r|", cfun_it_s64_or}, {"^", cfun_it_s64_xor}, {"r^", cfun_it_s64_xor}, {"~", cfun_it_s64_not}, {"<<", cfun_it_s64_lshift}, {">>", cfun_it_s64_rshift}, {"compare", cfun_it_s64_compare}, {NULL, NULL} }; static JanetMethod it_u64_methods[] = { {"+", cfun_it_u64_add}, {"r+", cfun_it_u64_add}, {"-", cfun_it_u64_sub}, {"r-", cfun_it_u64_subi}, {"*", cfun_it_u64_mul}, {"r*", cfun_it_u64_mul}, {"/", cfun_it_u64_div}, {"r/", cfun_it_u64_divi}, {"div", cfun_it_u64_div}, {"rdiv", cfun_it_u64_divi}, {"mod", cfun_it_u64_mod}, {"rmod", cfun_it_u64_modi}, {"%", cfun_it_u64_rem}, {"r%", cfun_it_u64_remi}, {"&", cfun_it_u64_and}, {"r&", cfun_it_u64_and}, {"|", cfun_it_u64_or}, {"r|", cfun_it_u64_or}, {"^", cfun_it_u64_xor}, {"r^", cfun_it_u64_xor}, {"~", cfun_it_u64_not}, {"<<", cfun_it_u64_lshift}, {">>", cfun_it_u64_rshift}, {"compare", cfun_it_u64_compare}, {NULL, NULL} }; static Janet janet_int64_next(void *p, Janet key) { (void) p; return janet_nextmethod(it_s64_methods, key); } static Janet janet_uint64_next(void *p, Janet key) { (void) p; return janet_nextmethod(it_u64_methods, key); } static int it_s64_get(void *p, Janet key, Janet *out) { (void) p; if (!janet_checktype(key, JANET_KEYWORD)) return 0; return janet_getmethod(janet_unwrap_keyword(key), it_s64_methods, out); } static int it_u64_get(void *p, Janet key, Janet *out) { (void) p; if (!janet_checktype(key, JANET_KEYWORD)) return 0; return janet_getmethod(janet_unwrap_keyword(key), it_u64_methods, out); } /* Module entry point */ void janet_lib_inttypes(JanetTable *env) { JanetRegExt it_cfuns[] = { JANET_CORE_REG("int/s64", cfun_it_s64_new), JANET_CORE_REG("int/u64", cfun_it_u64_new), JANET_CORE_REG("int/to-number", cfun_to_number), JANET_CORE_REG("int/to-bytes", cfun_to_bytes), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, it_cfuns); janet_register_abstract_type(&janet_s64_type); janet_register_abstract_type(&janet_u64_type); } #endif janet-1.41.2/src/core/io.c000066400000000000000000000733631514534607600152210ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "util.h" #endif #include #include #ifndef JANET_WINDOWS #include #include #include #include #endif static int cfun_io_gc(void *p, size_t len); static int io_file_get(void *p, Janet key, Janet *out); static void io_file_marshal(void *p, JanetMarshalContext *ctx); static void *io_file_unmarshal(JanetMarshalContext *ctx); static Janet io_file_next(void *p, Janet key); #ifdef JANET_WINDOWS #define ftell _ftelli64 #define fseek _fseeki64 #endif const JanetAbstractType janet_file_type = { "core/file", cfun_io_gc, NULL, io_file_get, NULL, io_file_marshal, io_file_unmarshal, NULL, /* tostring */ NULL, /* compare */ NULL, /* hash */ io_file_next, JANET_ATEND_NEXT }; /* Check arguments to fopen */ static int32_t checkflags(const uint8_t *str) { int32_t flags = 0; int32_t i; int32_t len = janet_string_length(str); if (!len || len > 10) janet_panic("file mode must have a length between 1 and 10"); switch (*str) { default: janet_panicf("invalid flag %c, expected w, a, or r", *str); break; case 'w': flags |= JANET_FILE_WRITE; janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); break; case 'a': flags |= JANET_FILE_APPEND; janet_sandbox_assert(JANET_SANDBOX_FS); break; case 'r': flags |= JANET_FILE_READ; janet_sandbox_assert(JANET_SANDBOX_FS_READ); break; } for (i = 1; i < len; i++) { switch (str[i]) { default: janet_panicf("invalid flag %c, expected +, b, or n", str[i]); break; case '+': if (flags & JANET_FILE_UPDATE) return -1; janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); flags |= JANET_FILE_UPDATE; break; case 'b': if (flags & JANET_FILE_BINARY) return -1; flags |= JANET_FILE_BINARY; break; case 'n': if (flags & JANET_FILE_NONIL) return -1; flags |= JANET_FILE_NONIL; break; } } return flags; } static void *makef(FILE *f, int32_t flags) { JanetFile *iof = (JanetFile *) janet_abstract(&janet_file_type, sizeof(JanetFile)); iof->file = f; iof->flags = flags; #if !(defined(JANET_WINDOWS) || defined(JANET_PLAN9)) /* While we would like fopen to set cloexec by default (like O_CLOEXEC) with the e flag, that is * not standard. */ if (!(flags & JANET_FILE_NOT_CLOSEABLE)) fcntl(fileno(f), F_SETFD, FD_CLOEXEC); #endif return iof; } JANET_CORE_FN(cfun_io_temp, "(file/temp)", "Open an anonymous temporary file that is removed on close. " "Raises an error on failure.") { janet_sandbox_assert(JANET_SANDBOX_FS_TEMP); (void)argv; janet_fixarity(argc, 0); // XXX use mkostemp when we can to avoid CLOEXEC race. FILE *tmp = tmpfile(); if (!tmp) janet_panicf("unable to create temporary file - %s", janet_strerror(errno)); return janet_makefile(tmp, JANET_FILE_WRITE | JANET_FILE_READ | JANET_FILE_BINARY); } JANET_CORE_FN(cfun_io_fopen, "(file/open path &opt mode buffer-size)", "Open a file. `path` is an absolute or relative path, and " "`mode` is a set of flags indicating the mode to open the file in. " "`mode` is a keyword where each character represents a flag. If the file " "cannot be opened, returns nil, otherwise returns the new file handle. " "Mode flags:\n\n" "* r - allow reading from the file\n\n" "* w - allow writing to the file\n\n" "* a - append to the file\n\n" "Following one of the initial flags, 0 or more of the following flags can be appended:\n\n" "* b - open the file in binary mode (rather than text mode)\n\n" "* + - append to the file instead of overwriting it\n\n" "* n - error if the file cannot be opened instead of returning nil\n\n" "See fopen (, C99) for further details.") { janet_arity(argc, 1, 3); const uint8_t *fname = janet_getstring(argv, 0); const uint8_t *fmode; int32_t flags; if (argc == 2) { fmode = janet_getkeyword(argv, 1); flags = checkflags(fmode); } else { fmode = (const uint8_t *)"r"; janet_sandbox_assert(JANET_SANDBOX_FS_READ); flags = JANET_FILE_READ; } FILE *f = fopen((const char *)fname, (const char *)fmode); if (f != NULL) { #if !(defined(JANET_WINDOWS) || defined(JANET_PLAN9)) struct stat st; fstat(fileno(f), &st); if (S_ISDIR(st.st_mode)) { fclose(f); janet_panicf("cannot open directory: %s", fname); } #endif size_t bufsize = janet_optsize(argv, argc, 2, BUFSIZ); if (bufsize != BUFSIZ) { int result = setvbuf(f, NULL, bufsize ? _IOFBF : _IONBF, bufsize); if (result) { janet_panic("failed to set buffer size for file"); } } } return f ? janet_makefile(f, flags) : (flags & JANET_FILE_NONIL) ? (janet_panicf("failed to open file %s: %s", fname, janet_strerror(errno)), janet_wrap_nil()) : janet_wrap_nil(); } /* Read up to n bytes into buffer. */ static void read_chunk(JanetFile *iof, JanetBuffer *buffer, int32_t nBytesMax) { if (!(iof->flags & (JANET_FILE_READ | JANET_FILE_UPDATE))) janet_panic("file is not readable"); janet_buffer_extra(buffer, nBytesMax); size_t ntoread = nBytesMax; size_t nread = fread((char *)(buffer->data + buffer->count), 1, ntoread, iof->file); if (nread != ntoread && ferror(iof->file)) janet_panic("could not read file"); buffer->count += (int32_t) nread; } /* Read a certain number of bytes into memory */ JANET_CORE_FN(cfun_io_fread, "(file/read f what &opt buf)", "Read a number of bytes from a file `f` into a buffer. A buffer `buf` can " "be provided as an optional third argument, otherwise a new buffer " "is created. `what` can either be an integer or a keyword. Returns the " "buffer with file contents. " "Values for `what`:\n\n" "* :all - read the whole file\n\n" "* :line - read up to and including the next newline character\n\n" "* n (integer) - read up to n bytes from the file") { janet_arity(argc, 2, 3); JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type); if (iof->flags & JANET_FILE_CLOSED) janet_panic("file is closed"); JanetBuffer *buffer; if (argc == 2) { buffer = janet_buffer(0); } else { buffer = janet_getbuffer(argv, 2); } int32_t bufstart = buffer->count; if (janet_checktype(argv[1], JANET_KEYWORD)) { const uint8_t *sym = janet_unwrap_keyword(argv[1]); if (!janet_cstrcmp(sym, "all")) { int32_t sizeBefore; do { sizeBefore = buffer->count; read_chunk(iof, buffer, 4096); } while (sizeBefore < buffer->count); /* Never return nil for :all */ return janet_wrap_buffer(buffer); } else if (!janet_cstrcmp(sym, "line")) { for (;;) { int x = fgetc(iof->file); if (x != EOF) janet_buffer_push_u8(buffer, (uint8_t)x); if (x == EOF || x == '\n') break; } } else { janet_panicf("expected one of :all, :line, got %v", argv[1]); } } else { int32_t len = janet_getinteger(argv, 1); if (len < 0) janet_panic("expected positive integer"); read_chunk(iof, buffer, len); } if (bufstart == buffer->count) return janet_wrap_nil(); return janet_wrap_buffer(buffer); } /* Write bytes to a file */ JANET_CORE_FN(cfun_io_fwrite, "(file/write f & bytes)", "Writes to a file `f`. Each value of `bytes` must be a " "string, buffer, symbol, or keyword. Returns the file.") { janet_arity(argc, 1, -1); JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type); if (iof->flags & JANET_FILE_CLOSED) janet_panic("file is closed"); if (!(iof->flags & (JANET_FILE_WRITE | JANET_FILE_APPEND | JANET_FILE_UPDATE))) janet_panic("file is not writeable"); int32_t i; /* Verify all arguments before writing to file */ for (i = 1; i < argc; i++) janet_getbytes(argv, i); for (i = 1; i < argc; i++) { JanetByteView view = janet_getbytes(argv, i); if (view.len) { if (!fwrite(view.bytes, view.len, 1, iof->file)) { janet_panic("error writing to file"); } } } return argv[0]; } static void io_assert_writeable(JanetFile *iof) { if (iof->flags & JANET_FILE_CLOSED) janet_panic("file is closed"); if (!(iof->flags & (JANET_FILE_WRITE | JANET_FILE_APPEND | JANET_FILE_UPDATE))) janet_panic("file is not writeable"); } /* Flush the bytes in the file */ JANET_CORE_FN(cfun_io_fflush, "(file/flush f)", "Flush any buffered bytes to the file system. In most files, writes are " "buffered for efficiency reasons. Returns the file handle.") { janet_fixarity(argc, 1); JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type); io_assert_writeable(iof); if (fflush(iof->file)) janet_panic("could not flush file"); return argv[0]; } #ifdef JANET_WINDOWS #define WEXITSTATUS(x) x #endif /* For closing files from C API */ int janet_file_close(JanetFile *file) { int ret = 0; if (!(file->flags & (JANET_FILE_NOT_CLOSEABLE | JANET_FILE_CLOSED))) { ret = fclose(file->file); file->flags |= JANET_FILE_CLOSED; file->file = NULL; /* NULL dereference is easier to debug then other problems */ return ret; } return 0; } /* Cleanup a file */ static int cfun_io_gc(void *p, size_t len) { (void) len; JanetFile *iof = (JanetFile *)p; janet_file_close(iof); return 0; } /* Close a file */ JANET_CORE_FN(cfun_io_fclose, "(file/close f)", "Close a file and release all related resources. When you are " "done reading a file, close it to prevent a resource leak and let " "other processes read the file.") { janet_fixarity(argc, 1); JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type); if (iof->flags & JANET_FILE_CLOSED) return janet_wrap_nil(); if (iof->flags & (JANET_FILE_NOT_CLOSEABLE)) janet_panic("file not closable"); if (fclose(iof->file)) { iof->flags |= JANET_FILE_NOT_CLOSEABLE; janet_panic("could not close file"); } iof->flags |= JANET_FILE_CLOSED; return janet_wrap_nil(); } /* Seek a file */ JANET_CORE_FN(cfun_io_fseek, "(file/seek f &opt whence n)", "Jump to a relative location in the file `f`. `whence` must be one of:\n\n" "* :cur - jump relative to the current file location\n\n" "* :set - jump relative to the beginning of the file\n\n" "* :end - jump relative to the end of the file\n\n" "By default, `whence` is :cur. Optionally a value `n` may be passed " "for the relative number of bytes to seek in the file. `n` may be a real " "number to handle large files of more than 4GB. Returns the file handle.") { janet_arity(argc, 2, 3); JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type); if (iof->flags & JANET_FILE_CLOSED) janet_panic("file is closed"); int64_t offset = 0; int whence = SEEK_CUR; if (argc >= 2) { const uint8_t *whence_sym = janet_getkeyword(argv, 1); if (!janet_cstrcmp(whence_sym, "cur")) { whence = SEEK_CUR; } else if (!janet_cstrcmp(whence_sym, "set")) { whence = SEEK_SET; } else if (!janet_cstrcmp(whence_sym, "end")) { whence = SEEK_END; } else { janet_panicf("expected one of :cur, :set, :end, got %v", argv[1]); } if (argc == 3) { offset = (int64_t) janet_getinteger64(argv, 2); } } if (fseek(iof->file, offset, whence)) janet_panic("error seeking file"); return argv[0]; } JANET_CORE_FN(cfun_io_ftell, "(file/tell f)", "Get the current value of the file position for file `f`.") { janet_fixarity(argc, 1); JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type); if (iof->flags & JANET_FILE_CLOSED) janet_panic("file is closed"); int64_t pos = ftell(iof->file); if (pos == -1) janet_panic("error getting position in file"); return janet_wrap_number((double)pos); } static JanetMethod io_file_methods[] = { {"close", cfun_io_fclose}, {"flush", cfun_io_fflush}, {"read", cfun_io_fread}, {"seek", cfun_io_fseek}, {"tell", cfun_io_ftell}, {"write", cfun_io_fwrite}, {NULL, NULL} }; static int io_file_get(void *p, Janet key, Janet *out) { (void) p; if (!janet_checktype(key, JANET_KEYWORD)) return 0; return janet_getmethod(janet_unwrap_keyword(key), io_file_methods, out); } static Janet io_file_next(void *p, Janet key) { (void) p; return janet_nextmethod(io_file_methods, key); } static void io_file_marshal(void *p, JanetMarshalContext *ctx) { JanetFile *iof = (JanetFile *)p; if (ctx->flags & JANET_MARSHAL_UNSAFE) { janet_marshal_abstract(ctx, p); #ifdef JANET_WINDOWS janet_marshal_int(ctx, _fileno(iof->file)); #else janet_marshal_int(ctx, fileno(iof->file)); #endif janet_marshal_int(ctx, iof->flags); } else { janet_panic("cannot marshal file in safe mode"); } } static void *io_file_unmarshal(JanetMarshalContext *ctx) { if (ctx->flags & JANET_MARSHAL_UNSAFE) { JanetFile *iof = janet_unmarshal_abstract(ctx, sizeof(JanetFile)); int32_t fd = janet_unmarshal_int(ctx); int32_t flags = janet_unmarshal_int(ctx); char fmt[4] = {0}; int index = 0; if (flags & JANET_FILE_READ) fmt[index++] = 'r'; if (flags & JANET_FILE_APPEND) { fmt[index++] = 'a'; } else if (flags & JANET_FILE_WRITE) { fmt[index++] = 'w'; } #ifdef JANET_WINDOWS iof->file = _fdopen(fd, fmt); #else iof->file = fdopen(fd, fmt); #endif if (iof->file == NULL) { iof->flags = JANET_FILE_CLOSED; } else { iof->flags = flags; } return iof; } else { janet_panic("cannot unmarshal file in safe mode"); } } FILE *janet_dynfile(const char *name, FILE *def) { Janet x = janet_dyn(name); if (!janet_checktype(x, JANET_ABSTRACT)) return def; void *abstract = janet_unwrap_abstract(x); if (janet_abstract_type(abstract) != &janet_file_type) return def; JanetFile *iofile = abstract; return iofile->file; } static Janet cfun_io_print_impl_x(int32_t argc, Janet *argv, int newline, FILE *dflt_file, int32_t offset, Janet x) { FILE *f; switch (janet_type(x)) { default: janet_panicf("cannot print to %v", x); case JANET_BUFFER: { /* Special case buffer */ JanetBuffer *buf = janet_unwrap_buffer(x); for (int32_t i = offset; i < argc; ++i) { janet_to_string_b(buf, argv[i]); } if (newline) janet_buffer_push_u8(buf, '\n'); return janet_wrap_nil(); } case JANET_FUNCTION: { /* Special case function */ JanetFunction *fun = janet_unwrap_function(x); JanetBuffer *buf = janet_buffer(0); for (int32_t i = offset; i < argc; ++i) { janet_to_string_b(buf, argv[i]); } if (newline) janet_buffer_push_u8(buf, '\n'); Janet args[1] = { janet_wrap_buffer(buf) }; janet_call(fun, 1, args); return janet_wrap_nil(); } case JANET_NIL: f = dflt_file; if (f == NULL) janet_panic("cannot print to nil"); break; case JANET_ABSTRACT: { void *abstract = janet_unwrap_abstract(x); if (janet_abstract_type(abstract) != &janet_file_type) return janet_wrap_nil(); JanetFile *iofile = abstract; io_assert_writeable(iofile); f = iofile->file; break; } } for (int32_t i = offset; i < argc; ++i) { int32_t len; const uint8_t *vstr; if (janet_checktype(argv[i], JANET_BUFFER)) { JanetBuffer *b = janet_unwrap_buffer(argv[i]); vstr = b->data; len = b->count; } else { vstr = janet_to_string(argv[i]); len = janet_string_length(vstr); } if (len) { if (1 != fwrite(vstr, len, 1, f)) { if (f == dflt_file) { janet_panicf("cannot print %d bytes", len); } else { janet_panicf("cannot print %d bytes to %v", len, x); } } } } if (newline) putc('\n', f); return janet_wrap_nil(); } static Janet cfun_io_print_impl(int32_t argc, Janet *argv, int newline, const char *name, FILE *dflt_file) { Janet x = janet_dyn(name); return cfun_io_print_impl_x(argc, argv, newline, dflt_file, 0, x); } JANET_CORE_FN(cfun_io_print, "(print & xs)", "Print values to the console (standard out). Value are converted " "to strings if they are not already. After printing all values, a " "newline character is printed. Use the value of `(dyn :out stdout)` to determine " "what to push characters to. Expects `(dyn :out stdout)` to be either a core/file or " "a buffer. Returns nil.") { return cfun_io_print_impl(argc, argv, 1, "out", stdout); } JANET_CORE_FN(cfun_io_prin, "(prin & xs)", "Same as `print`, but does not add trailing newline.") { return cfun_io_print_impl(argc, argv, 0, "out", stdout); } JANET_CORE_FN(cfun_io_eprint, "(eprint & xs)", "Same as `print`, but uses `(dyn :err stderr)` instead of `(dyn :out stdout)`.") { return cfun_io_print_impl(argc, argv, 1, "err", stderr); } JANET_CORE_FN(cfun_io_eprin, "(eprin & xs)", "Same as `prin`, but uses `(dyn :err stderr)` instead of `(dyn :out stdout)`.") { return cfun_io_print_impl(argc, argv, 0, "err", stderr); } JANET_CORE_FN(cfun_io_xprint, "(xprint to & xs)", "Print to a file or other value explicitly (no dynamic bindings) with a trailing " "newline character. The value to print " "to is the first argument, and is otherwise the same as `print`. Returns nil.") { janet_arity(argc, 1, -1); return cfun_io_print_impl_x(argc, argv, 1, NULL, 1, argv[0]); } JANET_CORE_FN(cfun_io_xprin, "(xprin to & xs)", "Print to a file or other value explicitly (no dynamic bindings). The value to print " "to is the first argument, and is otherwise the same as `prin`. Returns nil.") { janet_arity(argc, 1, -1); return cfun_io_print_impl_x(argc, argv, 0, NULL, 1, argv[0]); } static Janet cfun_io_printf_impl_x(int32_t argc, Janet *argv, int newline, FILE *dflt_file, int32_t offset, Janet x) { FILE *f; const char *fmt = janet_getcstring(argv, offset); switch (janet_type(x)) { default: janet_panicf("cannot print to %v", x); case JANET_BUFFER: { /* Special case buffer */ JanetBuffer *buf = janet_unwrap_buffer(x); janet_buffer_format(buf, fmt, offset, argc, argv); if (newline) janet_buffer_push_u8(buf, '\n'); return janet_wrap_nil(); } case JANET_FUNCTION: { /* Special case function */ JanetFunction *fun = janet_unwrap_function(x); JanetBuffer *buf = janet_buffer(0); janet_buffer_format(buf, fmt, offset, argc, argv); if (newline) janet_buffer_push_u8(buf, '\n'); Janet args[1] = { janet_wrap_buffer(buf) }; janet_call(fun, 1, args); return janet_wrap_nil(); } case JANET_NIL: f = dflt_file; if (f == NULL) janet_panic("cannot print to nil"); break; case JANET_ABSTRACT: { void *abstract = janet_unwrap_abstract(x); if (janet_abstract_type(abstract) != &janet_file_type) return janet_wrap_nil(); JanetFile *iofile = abstract; if (iofile->flags & JANET_FILE_CLOSED) { janet_panic("cannot print to closed file"); } io_assert_writeable(iofile); f = iofile->file; break; } } JanetBuffer *buf = janet_buffer(10); janet_buffer_format(buf, fmt, offset, argc, argv); if (newline) janet_buffer_push_u8(buf, '\n'); if (buf->count) { if (1 != fwrite(buf->data, buf->count, 1, f)) { janet_panicf("could not print %d bytes to file", buf->count); } } /* Clear buffer to make things easier for GC */ buf->count = 0; buf->capacity = 0; janet_free(buf->data); buf->data = NULL; return janet_wrap_nil(); } static Janet cfun_io_printf_impl(int32_t argc, Janet *argv, int newline, const char *name, FILE *dflt_file) { janet_arity(argc, 1, -1); Janet x = janet_dyn(name); return cfun_io_printf_impl_x(argc, argv, newline, dflt_file, 0, x); } JANET_CORE_FN(cfun_io_printf, "(printf fmt & xs)", "Prints output formatted as if with `(string/format fmt ;xs)` to `(dyn :out stdout)` with a trailing newline.") { return cfun_io_printf_impl(argc, argv, 1, "out", stdout); } JANET_CORE_FN(cfun_io_prinf, "(prinf fmt & xs)", "Like `printf` but with no trailing newline.") { return cfun_io_printf_impl(argc, argv, 0, "out", stdout); } JANET_CORE_FN(cfun_io_eprintf, "(eprintf fmt & xs)", "Prints output formatted as if with `(string/format fmt ;xs)` to `(dyn :err stderr)` with a trailing newline.") { return cfun_io_printf_impl(argc, argv, 1, "err", stderr); } JANET_CORE_FN(cfun_io_eprinf, "(eprinf fmt & xs)", "Like `eprintf` but with no trailing newline.") { return cfun_io_printf_impl(argc, argv, 0, "err", stderr); } JANET_CORE_FN(cfun_io_xprintf, "(xprintf to fmt & xs)", "Like `printf` but prints to an explicit file or value `to`. Returns nil.") { janet_arity(argc, 2, -1); return cfun_io_printf_impl_x(argc, argv, 1, NULL, 1, argv[0]); } JANET_CORE_FN(cfun_io_xprinf, "(xprinf to fmt & xs)", "Like `prinf` but prints to an explicit file or value `to`. Returns nil.") { janet_arity(argc, 2, -1); return cfun_io_printf_impl_x(argc, argv, 0, NULL, 1, argv[0]); } static void janet_flusher(const char *name, FILE *dflt_file) { Janet x = janet_dyn(name); switch (janet_type(x)) { default: break; case JANET_NIL: fflush(dflt_file); break; case JANET_ABSTRACT: { void *abstract = janet_unwrap_abstract(x); if (janet_abstract_type(abstract) != &janet_file_type) break; JanetFile *iofile = abstract; fflush(iofile->file); break; } } } JANET_CORE_FN(cfun_io_flush, "(flush)", "Flush `(dyn :out stdout)` if it is a file, otherwise do nothing.") { janet_fixarity(argc, 0); (void) argv; janet_flusher("out", stdout); return janet_wrap_nil(); } JANET_CORE_FN(cfun_io_eflush, "(eflush)", "Flush `(dyn :err stderr)` if it is a file, otherwise do nothing.") { janet_fixarity(argc, 0); (void) argv; janet_flusher("err", stderr); return janet_wrap_nil(); } void janet_dynprintf(const char *name, FILE *dflt_file, const char *format, ...) { va_list args; va_start(args, format); JanetType xtype; Janet x; if (!name || name[0] == '\0') { /* Allow NULL or empty string to just use dflt_file directly */ x = janet_wrap_nil(); xtype = JANET_NIL; } else { x = janet_dyn(name); xtype = janet_type(x); } switch (xtype) { default: /* Other values simply do nothing */ break; case JANET_NIL: case JANET_ABSTRACT: { FILE *f = dflt_file; JanetBuffer buffer; int32_t len = 0; while (format[len]) len++; janet_buffer_init(&buffer, len); janet_formatbv(&buffer, format, args); if (xtype == JANET_ABSTRACT) { void *abstract = janet_unwrap_abstract(x); if (janet_abstract_type(abstract) != &janet_file_type) break; JanetFile *iofile = abstract; io_assert_writeable(iofile); f = iofile->file; } fwrite(buffer.data, buffer.count, 1, f); janet_buffer_deinit(&buffer); break; } case JANET_FUNCTION: { JanetFunction *fun = janet_unwrap_function(x); int32_t len = 0; while (format[len]) len++; JanetBuffer *buf = janet_buffer(len); janet_formatbv(buf, format, args); Janet args[1] = { janet_wrap_buffer(buf) }; janet_call(fun, 1, args); break; } case JANET_BUFFER: janet_formatbv(janet_unwrap_buffer(x), format, args); break; } va_end(args); return; } /* C API */ JanetFile *janet_getjfile(const Janet *argv, int32_t n) { return janet_getabstract(argv, n, &janet_file_type); } FILE *janet_getfile(const Janet *argv, int32_t n, int32_t *flags) { JanetFile *iof = janet_getabstract(argv, n, &janet_file_type); if (NULL != flags) *flags = iof->flags; return iof->file; } JanetFile *janet_makejfile(FILE *f, int32_t flags) { return makef(f, flags); } Janet janet_makefile(FILE *f, int32_t flags) { return janet_wrap_abstract(makef(f, flags)); } JanetAbstract janet_checkfile(Janet j) { return janet_checkabstract(j, &janet_file_type); } FILE *janet_unwrapfile(Janet j, int32_t *flags) { JanetFile *iof = janet_unwrap_abstract(j); if (NULL != flags) *flags = iof->flags; return iof->file; } /* Module entry point */ void janet_lib_io(JanetTable *env) { JanetRegExt io_cfuns[] = { JANET_CORE_REG("print", cfun_io_print), JANET_CORE_REG("prin", cfun_io_prin), JANET_CORE_REG("printf", cfun_io_printf), JANET_CORE_REG("prinf", cfun_io_prinf), JANET_CORE_REG("eprin", cfun_io_eprin), JANET_CORE_REG("eprint", cfun_io_eprint), JANET_CORE_REG("eprintf", cfun_io_eprintf), JANET_CORE_REG("eprinf", cfun_io_eprinf), JANET_CORE_REG("xprint", cfun_io_xprint), JANET_CORE_REG("xprin", cfun_io_xprin), JANET_CORE_REG("xprintf", cfun_io_xprintf), JANET_CORE_REG("xprinf", cfun_io_xprinf), JANET_CORE_REG("flush", cfun_io_flush), JANET_CORE_REG("eflush", cfun_io_eflush), JANET_CORE_REG("file/temp", cfun_io_temp), JANET_CORE_REG("file/open", cfun_io_fopen), JANET_CORE_REG("file/close", cfun_io_fclose), JANET_CORE_REG("file/read", cfun_io_fread), JANET_CORE_REG("file/write", cfun_io_fwrite), JANET_CORE_REG("file/flush", cfun_io_fflush), JANET_CORE_REG("file/seek", cfun_io_fseek), JANET_CORE_REG("file/tell", cfun_io_ftell), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, io_cfuns); janet_register_abstract_type(&janet_file_type); int default_flags = JANET_FILE_NOT_CLOSEABLE | JANET_FILE_SERIALIZABLE; /* stdout */ JANET_CORE_DEF(env, "stdout", janet_makefile(stdout, JANET_FILE_APPEND | default_flags), "The standard output file."); /* stderr */ JANET_CORE_DEF(env, "stderr", janet_makefile(stderr, JANET_FILE_APPEND | default_flags), "The standard error file."); /* stdin */ JANET_CORE_DEF(env, "stdin", janet_makefile(stdin, JANET_FILE_READ | default_flags), "The standard input file."); } janet-1.41.2/src/core/marsh.c000066400000000000000000001672561514534607600157310ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "state.h" #include "vector.h" #include "gc.h" #include "fiber.h" #include "util.h" #endif typedef struct { JanetBuffer *buf; JanetTable seen; JanetTable *rreg; JanetFuncEnv **seen_envs; JanetFuncDef **seen_defs; int32_t nextid; int maybe_cycles; } MarshalState; /* Lead bytes in marshaling protocol */ enum { LB_REAL = 200, LB_NIL, /* 201 */ LB_FALSE, /* 202 */ LB_TRUE, /* 203 */ LB_FIBER, /* 204 */ LB_INTEGER, /* 205 */ LB_STRING, /* 206 */ LB_SYMBOL, /* 207 */ LB_KEYWORD, /* 208 */ LB_ARRAY, /* 209 */ LB_TUPLE, /* 210 */ LB_TABLE, /* 211 */ LB_TABLE_PROTO, /* 212 */ LB_STRUCT, /* 213 */ LB_BUFFER, /* 214 */ LB_FUNCTION, /* 215 */ LB_REGISTRY, /* 216 */ LB_ABSTRACT, /* 217 */ LB_REFERENCE, /* 218 */ LB_FUNCENV_REF, /* 219 */ LB_FUNCDEF_REF, /* 220 */ LB_UNSAFE_CFUNCTION, /* 221 */ LB_UNSAFE_POINTER, /* 222 */ LB_STRUCT_PROTO, /* 223 */ #ifdef JANET_EV LB_THREADED_ABSTRACT, /* 224 */ LB_POINTER_BUFFER, /* 225 */ #endif LB_TABLE_WEAKK, /* 226 */ LB_TABLE_WEAKV, /* 227 */ LB_TABLE_WEAKKV, /* 228 */ LB_TABLE_WEAKK_PROTO, /* 229 */ LB_TABLE_WEAKV_PROTO, /* 230 */ LB_TABLE_WEAKKV_PROTO, /* 231 */ LB_ARRAY_WEAK, /* 232 */ } LeadBytes; /* Helper to look inside an entry in an environment */ static Janet entry_getval(Janet env_entry) { if (janet_checktype(env_entry, JANET_TABLE)) { JanetTable *entry = janet_unwrap_table(env_entry); Janet checkval = janet_table_get(entry, janet_ckeywordv("value")); if (janet_checktype(checkval, JANET_NIL)) { checkval = janet_table_get(entry, janet_ckeywordv("ref")); } return checkval; } else if (janet_checktype(env_entry, JANET_STRUCT)) { const JanetKV *entry = janet_unwrap_struct(env_entry); Janet checkval = janet_struct_get(entry, janet_ckeywordv("value")); if (janet_checktype(checkval, JANET_NIL)) { checkval = janet_struct_get(entry, janet_ckeywordv("ref")); } return checkval; } else { return janet_wrap_nil(); } } /* Merge values from an environment into an existing lookup table. */ void janet_env_lookup_into(JanetTable *renv, JanetTable *env, const char *prefix, int recurse) { while (env) { for (int32_t i = 0; i < env->capacity; i++) { if (janet_checktype(env->data[i].key, JANET_SYMBOL)) { if (prefix) { int32_t prelen = (int32_t) strlen(prefix); const uint8_t *oldsym = janet_unwrap_symbol(env->data[i].key); int32_t oldlen = janet_string_length(oldsym); uint8_t *symbuf = janet_smalloc(prelen + oldlen); safe_memcpy(symbuf, prefix, prelen); safe_memcpy(symbuf + prelen, oldsym, oldlen); Janet s = janet_symbolv(symbuf, prelen + oldlen); janet_sfree(symbuf); janet_table_put(renv, s, entry_getval(env->data[i].value)); } else { janet_table_put(renv, env->data[i].key, entry_getval(env->data[i].value)); } } } env = recurse ? env->proto : NULL; } } /* Make a forward lookup table from an environment (for unmarshaling) */ JanetTable *janet_env_lookup(JanetTable *env) { JanetTable *renv = janet_table(env->count); janet_env_lookup_into(renv, env, NULL, 1); return renv; } /* Marshal an integer onto the buffer */ static void pushint(MarshalState *st, int32_t x) { if (x >= 0 && x < 128) { janet_buffer_push_u8(st->buf, x); } else if (x <= 8191 && x >= -8192) { uint8_t intbuf[2]; intbuf[0] = ((x >> 8) & 0x3F) | 0x80; intbuf[1] = x & 0xFF; janet_buffer_push_bytes(st->buf, intbuf, 2); } else { uint8_t intbuf[5]; intbuf[0] = LB_INTEGER; intbuf[1] = (x >> 24) & 0xFF; intbuf[2] = (x >> 16) & 0xFF; intbuf[3] = (x >> 8) & 0xFF; intbuf[4] = x & 0xFF; janet_buffer_push_bytes(st->buf, intbuf, 5); } } static void pushbyte(MarshalState *st, uint8_t b) { janet_buffer_push_u8(st->buf, b); } static void pushbytes(MarshalState *st, const uint8_t *bytes, int32_t len) { janet_buffer_push_bytes(st->buf, bytes, len); } static void pushpointer(MarshalState *st, const void *ptr) { janet_buffer_push_bytes(st->buf, (const uint8_t *) &ptr, sizeof(ptr)); } /* Marshal a size_t onto the buffer */ static void push64(MarshalState *st, uint64_t x) { if (x <= 0xF0) { /* Single byte */ pushbyte(st, (uint8_t) x); } else { /* Multibyte, little endian */ uint8_t bytes[9]; int nbytes = 0; while (x) { bytes[++nbytes] = x & 0xFF; x >>= 8; } bytes[0] = 0xF0 + nbytes; pushbytes(st, bytes, nbytes + 1); } } /* Forward declaration to enable mutual recursion. */ static void marshal_one(MarshalState *st, Janet x, int flags); static void marshal_one_fiber(MarshalState *st, JanetFiber *fiber, int flags); static void marshal_one_def(MarshalState *st, JanetFuncDef *def, int flags); static void marshal_one_env(MarshalState *st, JanetFuncEnv *env, int flags); /* Prevent stack overflows */ #define MARSH_STACKCHECK if ((flags & 0xFFFF) > JANET_RECURSION_GUARD) janet_panic("stack overflow") /* Quick check if a fiber cannot be marshalled. This is will * have no false positives, but may have false negatives. */ static int fiber_cannot_be_marshalled(JanetFiber *fiber) { if (janet_fiber_status(fiber) == JANET_STATUS_ALIVE) return 1; int32_t i = fiber->frame; while (i > 0) { JanetStackFrame *frame = (JanetStackFrame *)(fiber->data + i - JANET_FRAME_SIZE); if (!frame->func) return 1; /* has cfunction on stack */ i = frame->prevframe; } return 0; } /* Marshal a function env */ static void marshal_one_env(MarshalState *st, JanetFuncEnv *env, int flags) { MARSH_STACKCHECK; for (int32_t i = 0; i < janet_v_count(st->seen_envs); i++) { if (st->seen_envs[i] == env) { pushbyte(st, LB_FUNCENV_REF); pushint(st, i); return; } } janet_env_valid(env); janet_v_push(st->seen_envs, env); /* Special case for early detachment */ if (env->offset > 0 && fiber_cannot_be_marshalled(env->as.fiber)) { pushint(st, 0); pushint(st, env->length); Janet *values = env->as.fiber->data + env->offset; uint32_t *bitset = janet_stack_frame(values)->func->def->closure_bitset; for (int32_t i = 0; i < env->length; i++) { if (1 & (bitset[i >> 5] >> (i & 0x1F))) { marshal_one(st, values[i], flags + 1); } else { pushbyte(st, LB_NIL); } } } else { janet_env_maybe_detach(env); pushint(st, env->offset); pushint(st, env->length); if (env->offset > 0) { /* On stack variant */ marshal_one(st, janet_wrap_fiber(env->as.fiber), flags + 1); } else { /* Off stack variant */ for (int32_t i = 0; i < env->length; i++) marshal_one(st, env->as.values[i], flags + 1); } } } /* Marshal a sequence of u32s */ static void janet_marshal_u32s(MarshalState *st, const uint32_t *u32s, int32_t n) { for (int32_t i = 0; i < n; i++) { pushbyte(st, u32s[i] & 0xFF); pushbyte(st, (u32s[i] >> 8) & 0xFF); pushbyte(st, (u32s[i] >> 16) & 0xFF); pushbyte(st, (u32s[i] >> 24) & 0xFF); } } /* Marshal a function def */ static void marshal_one_def(MarshalState *st, JanetFuncDef *def, int flags) { MARSH_STACKCHECK; for (int32_t i = 0; i < janet_v_count(st->seen_defs); i++) { if (st->seen_defs[i] == def) { pushbyte(st, LB_FUNCDEF_REF); pushint(st, i); return; } } /* Add to lookup */ janet_v_push(st->seen_defs, def); pushint(st, def->flags); pushint(st, def->slotcount); pushint(st, def->arity); pushint(st, def->min_arity); pushint(st, def->max_arity); pushint(st, def->constants_length); pushint(st, def->bytecode_length); if (def->flags & JANET_FUNCDEF_FLAG_NAMEDARGS) pushint(st, def->named_args_count); if (def->flags & JANET_FUNCDEF_FLAG_HASENVS) pushint(st, def->environments_length); if (def->flags & JANET_FUNCDEF_FLAG_HASDEFS) pushint(st, def->defs_length); if (def->flags & JANET_FUNCDEF_FLAG_HASSYMBOLMAP) pushint(st, def->symbolmap_length); if (def->flags & JANET_FUNCDEF_FLAG_HASNAME) marshal_one(st, janet_wrap_string(def->name), flags); if (def->flags & JANET_FUNCDEF_FLAG_HASSOURCE) marshal_one(st, janet_wrap_string(def->source), flags); /* marshal constants */ for (int32_t i = 0; i < def->constants_length; i++) marshal_one(st, def->constants[i], flags + 1); /* Marshal symbol map, if needed */ for (int32_t i = 0; i < def->symbolmap_length; i++) { pushint(st, (int32_t) def->symbolmap[i].birth_pc); pushint(st, (int32_t) def->symbolmap[i].death_pc); pushint(st, (int32_t) def->symbolmap[i].slot_index); marshal_one(st, janet_wrap_symbol(def->symbolmap[i].symbol), flags + 1); } /* marshal the bytecode */ janet_marshal_u32s(st, def->bytecode, def->bytecode_length); /* marshal the environments if needed */ for (int32_t i = 0; i < def->environments_length; i++) pushint(st, def->environments[i]); /* marshal the sub funcdefs if needed */ for (int32_t i = 0; i < def->defs_length; i++) marshal_one_def(st, def->defs[i], flags + 1); /* marshal source maps if needed */ if (def->flags & JANET_FUNCDEF_FLAG_HASSOURCEMAP) { int32_t current = 0; for (int32_t i = 0; i < def->bytecode_length; i++) { JanetSourceMapping map = def->sourcemap[i]; pushint(st, map.line - current); pushint(st, map.column); current = map.line; } } /* Marshal closure bitset, if needed */ if (def->flags & JANET_FUNCDEF_FLAG_HASCLOBITSET) { janet_marshal_u32s(st, def->closure_bitset, ((def->slotcount + 31) >> 5)); } } #define JANET_FIBER_FLAG_HASCHILD (1 << 29) #define JANET_FIBER_FLAG_HASENV (1 << 30) #define JANET_STACKFRAME_HASENV (INT32_MIN) /* Marshal a fiber */ static void marshal_one_fiber(MarshalState *st, JanetFiber *fiber, int flags) { MARSH_STACKCHECK; int32_t fflags = fiber->flags; if (fiber->child) fflags |= JANET_FIBER_FLAG_HASCHILD; if (fiber->env) fflags |= JANET_FIBER_FLAG_HASENV; if (janet_fiber_status(fiber) == JANET_STATUS_ALIVE) janet_panic("cannot marshal alive fiber"); pushint(st, fflags); pushint(st, fiber->frame); pushint(st, fiber->stackstart); pushint(st, fiber->stacktop); pushint(st, fiber->maxstack); /* Do frames */ int32_t i = fiber->frame; int32_t j = fiber->stackstart - JANET_FRAME_SIZE; while (i > 0) { JanetStackFrame *frame = (JanetStackFrame *)(fiber->data + i - JANET_FRAME_SIZE); if (frame->env) frame->flags |= JANET_STACKFRAME_HASENV; if (!frame->func) janet_panicf("cannot marshal fiber with c stackframe (%v)", janet_wrap_cfunction((JanetCFunction) frame->pc)); pushint(st, frame->flags); pushint(st, frame->prevframe); int32_t pcdiff = (int32_t)(frame->pc - frame->func->def->bytecode); pushint(st, pcdiff); marshal_one(st, janet_wrap_function(frame->func), flags + 1); if (frame->env) marshal_one_env(st, frame->env, flags + 1); /* Marshal all values in the stack frame */ for (int32_t k = i; k < j; k++) marshal_one(st, fiber->data[k], flags + 1); j = i - JANET_FRAME_SIZE; i = frame->prevframe; } if (fiber->env) { marshal_one(st, janet_wrap_table(fiber->env), flags + 1); } if (fiber->child) marshal_one(st, janet_wrap_fiber(fiber->child), flags + 1); marshal_one(st, fiber->last_value, flags + 1); } void janet_marshal_size(JanetMarshalContext *ctx, size_t value) { janet_marshal_int64(ctx, (int64_t) value); } void janet_marshal_int64(JanetMarshalContext *ctx, int64_t value) { MarshalState *st = (MarshalState *)(ctx->m_state); push64(st, (uint64_t) value); } void janet_marshal_int(JanetMarshalContext *ctx, int32_t value) { MarshalState *st = (MarshalState *)(ctx->m_state); pushint(st, value); } /* Only use in unsafe - don't marshal pointers otherwise */ void janet_marshal_ptr(JanetMarshalContext *ctx, const void *ptr) { if (!(ctx->flags & JANET_MARSHAL_UNSAFE)) { janet_panic("can only marshal pointers in unsafe mode"); } MarshalState *st = (MarshalState *)(ctx->m_state); pushpointer(st, ptr); } void janet_marshal_byte(JanetMarshalContext *ctx, uint8_t value) { MarshalState *st = (MarshalState *)(ctx->m_state); pushbyte(st, value); } void janet_marshal_bytes(JanetMarshalContext *ctx, const uint8_t *bytes, size_t len) { MarshalState *st = (MarshalState *)(ctx->m_state); if (len > INT32_MAX) janet_panic("size_t too large to fit in buffer"); pushbytes(st, bytes, (int32_t) len); } void janet_marshal_janet(JanetMarshalContext *ctx, Janet x) { MarshalState *st = (MarshalState *)(ctx->m_state); marshal_one(st, x, ctx->flags + 1); } #ifdef JANET_MARSHAL_DEBUG #define MARK_SEEN() \ do { if (st->maybe_cycles) { \ Janet _check = janet_table_get(&st->seen, x); \ if (!janet_checktype(_check, JANET_NIL)) janet_eprintf("double MARK_SEEN on %v\n", x); \ janet_eprintf("made reference %d (%t) to %v\n", st->nextid, x, x); \ janet_table_put(&st->seen, x, janet_wrap_integer(st->nextid++)); \ } } while (0) #else #define MARK_SEEN() \ do { if (st->maybe_cycles) { \ janet_table_put(&st->seen, x, janet_wrap_integer(st->nextid++)); \ } } while (0) #endif void janet_marshal_abstract(JanetMarshalContext *ctx, void *abstract) { MarshalState *st = (MarshalState *)(ctx->m_state); Janet x = janet_wrap_abstract(abstract); MARK_SEEN(); } static void marshal_one_abstract(MarshalState *st, Janet x, int flags) { void *abstract = janet_unwrap_abstract(x); #ifdef JANET_EV /* Threaded abstract types get passed through as pointers in the unsafe mode */ if ((flags & JANET_MARSHAL_UNSAFE) && (JANET_MEMORY_THREADED_ABSTRACT == (janet_abstract_head(abstract)->gc.flags & JANET_MEM_TYPEBITS))) { /* Increment refcount before sending message. This prevents a "death in transit" problem * where a message is garbage collected while in transit between two threads - i.e., the sending threads * loses the reference and runs a garbage collection before the receiving thread gets the message. */ janet_abstract_incref(abstract); pushbyte(st, LB_THREADED_ABSTRACT); pushbytes(st, (uint8_t *) &abstract, sizeof(abstract)); MARK_SEEN(); return; } #endif const JanetAbstractType *at = janet_abstract_type(abstract); if (at->marshal) { pushbyte(st, LB_ABSTRACT); marshal_one(st, janet_csymbolv(at->name), flags + 1); JanetMarshalContext context = {st, NULL, flags + 1, NULL, at}; at->marshal(abstract, &context); } else { janet_panicf("cannot marshal %p", x); } } /* The main body of the marshaling function. Is the main * entry point for the mutually recursive functions. */ static void marshal_one(MarshalState *st, Janet x, int flags) { MARSH_STACKCHECK; JanetType type = janet_type(x); /* Check simple primitives (non reference types, no benefit from memoization) */ switch (type) { default: break; case JANET_NIL: pushbyte(st, LB_NIL); return; case JANET_BOOLEAN: pushbyte(st, janet_unwrap_boolean(x) ? LB_TRUE : LB_FALSE); return; case JANET_NUMBER: { double xval = janet_unwrap_number(x); if (janet_checkintrange(xval)) { pushint(st, (int32_t) xval); return; } break; } } /* Check reference and registry value */ { Janet check; if (st->maybe_cycles) { check = janet_table_get(&st->seen, x); if (janet_checkint(check)) { pushbyte(st, LB_REFERENCE); pushint(st, janet_unwrap_integer(check)); return; } } if (st->rreg) { check = janet_table_get(st->rreg, x); if (janet_checktype(check, JANET_SYMBOL)) { MARK_SEEN(); const uint8_t *regname = janet_unwrap_symbol(check); pushbyte(st, LB_REGISTRY); pushint(st, janet_string_length(regname)); pushbytes(st, regname, janet_string_length(regname)); return; } } } /* Reference types */ switch (type) { case JANET_NUMBER: { union { double d; uint8_t bytes[8]; } u; u.d = janet_unwrap_number(x); #ifdef JANET_BIG_ENDIAN /* Swap byte order */ uint8_t temp; temp = u.bytes[7]; u.bytes[7] = u.bytes[0]; u.bytes[0] = temp; temp = u.bytes[6]; u.bytes[6] = u.bytes[1]; u.bytes[1] = temp; temp = u.bytes[5]; u.bytes[5] = u.bytes[2]; u.bytes[2] = temp; temp = u.bytes[4]; u.bytes[4] = u.bytes[3]; u.bytes[3] = temp; #endif pushbyte(st, LB_REAL); pushbytes(st, u.bytes, 8); MARK_SEEN(); return; } case JANET_STRING: case JANET_SYMBOL: case JANET_KEYWORD: { const uint8_t *str = janet_unwrap_string(x); int32_t length = janet_string_length(str); /* Record reference */ MARK_SEEN(); uint8_t lb = (type == JANET_STRING) ? LB_STRING : (type == JANET_SYMBOL) ? LB_SYMBOL : LB_KEYWORD; pushbyte(st, lb); pushint(st, length); pushbytes(st, str, length); return; } case JANET_BUFFER: { JanetBuffer *buffer = janet_unwrap_buffer(x); /* Record reference */ MARK_SEEN(); #ifdef JANET_EV if ((flags & JANET_MARSHAL_UNSAFE) && (buffer->gc.flags & JANET_BUFFER_FLAG_NO_REALLOC)) { pushbyte(st, LB_POINTER_BUFFER); pushint(st, buffer->count); pushint(st, buffer->capacity); pushpointer(st, buffer->data); return; } #endif pushbyte(st, LB_BUFFER); pushint(st, buffer->count); pushbytes(st, buffer->data, buffer->count); return; } case JANET_ARRAY: { int32_t i; JanetArray *a = janet_unwrap_array(x); MARK_SEEN(); enum JanetMemoryType memtype = janet_gc_type(a); pushbyte(st, memtype == JANET_MEMORY_ARRAY_WEAK ? LB_ARRAY_WEAK : LB_ARRAY); pushint(st, a->count); for (i = 0; i < a->count; i++) marshal_one(st, a->data[i], flags + 1); return; } case JANET_TUPLE: { int32_t i, count, flag; const Janet *tup = janet_unwrap_tuple(x); count = janet_tuple_length(tup); flag = janet_tuple_flag(tup) >> 16; pushbyte(st, LB_TUPLE); pushint(st, count); pushint(st, flag); for (i = 0; i < count; i++) marshal_one(st, tup[i], flags + 1); /* Mark as seen AFTER marshaling */ MARK_SEEN(); return; } case JANET_TABLE: { JanetTable *t = janet_unwrap_table(x); MARK_SEEN(); enum JanetMemoryType memtype = janet_gc_type(t); if (memtype == JANET_MEMORY_TABLE_WEAKK) { pushbyte(st, t->proto ? LB_TABLE_WEAKK_PROTO : LB_TABLE_WEAKK); } else if (memtype == JANET_MEMORY_TABLE_WEAKV) { pushbyte(st, t->proto ? LB_TABLE_WEAKV_PROTO : LB_TABLE_WEAKV); } else if (memtype == JANET_MEMORY_TABLE_WEAKKV) { pushbyte(st, t->proto ? LB_TABLE_WEAKKV_PROTO : LB_TABLE_WEAKKV); } else { pushbyte(st, t->proto ? LB_TABLE_PROTO : LB_TABLE); } pushint(st, t->count); if (t->proto) marshal_one(st, janet_wrap_table(t->proto), flags + 1); for (int32_t i = 0; i < t->capacity; i++) { if (janet_checktype(t->data[i].key, JANET_NIL)) continue; marshal_one(st, t->data[i].key, flags + 1); marshal_one(st, t->data[i].value, flags + 1); } return; } case JANET_STRUCT: { int32_t count; const JanetKV *struct_ = janet_unwrap_struct(x); count = janet_struct_length(struct_); pushbyte(st, janet_struct_proto(struct_) ? LB_STRUCT_PROTO : LB_STRUCT); pushint(st, count); if (janet_struct_proto(struct_)) marshal_one(st, janet_wrap_struct(janet_struct_proto(struct_)), flags + 1); for (int32_t i = 0; i < janet_struct_capacity(struct_); i++) { if (janet_checktype(struct_[i].key, JANET_NIL)) continue; marshal_one(st, struct_[i].key, flags + 1); marshal_one(st, struct_[i].value, flags + 1); } /* Mark as seen AFTER marshaling */ MARK_SEEN(); return; } case JANET_ABSTRACT: { marshal_one_abstract(st, x, flags); return; } case JANET_FUNCTION: { pushbyte(st, LB_FUNCTION); JanetFunction *func = janet_unwrap_function(x); pushint(st, func->def->environments_length); /* Mark seen before reading def */ MARK_SEEN(); marshal_one_def(st, func->def, flags); for (int32_t i = 0; i < func->def->environments_length; i++) marshal_one_env(st, func->envs[i], flags + 1); return; } case JANET_FIBER: { MARK_SEEN(); pushbyte(st, LB_FIBER); marshal_one_fiber(st, janet_unwrap_fiber(x), flags + 1); return; } case JANET_CFUNCTION: { if (!(flags & JANET_MARSHAL_UNSAFE)) goto no_registry; MARK_SEEN(); pushbyte(st, LB_UNSAFE_CFUNCTION); JanetCFunction cfn = janet_unwrap_cfunction(x); pushbytes(st, (uint8_t *) &cfn, sizeof(JanetCFunction)); return; } case JANET_POINTER: { if (!(flags & JANET_MARSHAL_UNSAFE)) goto no_registry; MARK_SEEN(); pushbyte(st, LB_UNSAFE_POINTER); pushpointer(st, janet_unwrap_pointer(x)); return; } no_registry: default: { janet_panicf("no registry value and cannot marshal %p", x); } } #undef MARK_SEEN } void janet_marshal( JanetBuffer *buf, Janet x, JanetTable *rreg, int flags) { MarshalState st; st.buf = buf; st.nextid = 0; st.seen_defs = NULL; st.seen_envs = NULL; st.rreg = rreg; st.maybe_cycles = !(flags & JANET_MARSHAL_NO_CYCLES); janet_table_init(&st.seen, 0); marshal_one(&st, x, flags); janet_table_deinit(&st.seen); janet_v_free(st.seen_envs); janet_v_free(st.seen_defs); } typedef struct { jmp_buf err; Janet *lookup; JanetTable *reg; JanetFuncEnv **lookup_envs; JanetFuncDef **lookup_defs; const uint8_t *start; const uint8_t *end; } UnmarshalState; #define MARSH_EOS(st, data) do { \ if ((data) >= (st)->end) janet_panic("unexpected end of source");\ } while (0) /* Helper to read a 32 bit integer from an unmarshal state */ static int32_t readint(UnmarshalState *st, const uint8_t **atdata) { const uint8_t *data = *atdata; int32_t ret; MARSH_EOS(st, data); if (*data < 128) { ret = *data++; } else if (*data < 192) { MARSH_EOS(st, data + 1); uint32_t uret = ((data[0] & 0x3F) << 8) + data[1]; /* Sign extend 18 MSBs */ uret |= (uret >> 13) ? 0xFFFFC000 : 0; ret = (int32_t)uret; data += 2; } else if (*data == LB_INTEGER) { MARSH_EOS(st, data + 4); uint32_t ui = ((uint32_t)(data[1]) << 24) | ((uint32_t)(data[2]) << 16) | ((uint32_t)(data[3]) << 8) | (uint32_t)(data[4]); ret = (int32_t)ui; data += 5; } else { janet_panicf("expected integer, got byte %x at index %d", *data, data - st->start); ret = 0; } *atdata = data; return ret; } /* Helper to read a natural number (int >= 0). */ static int32_t readnat(UnmarshalState *st, const uint8_t **atdata) { int32_t ret = readint(st, atdata); if (ret < 0) { janet_panicf("expected integer >= 0, got %d", ret); } return ret; } /* Helper to read a size_t (up to 8 bytes unsigned). */ static uint64_t read64(UnmarshalState *st, const uint8_t **atdata) { uint64_t ret; const uint8_t *data = *atdata; MARSH_EOS(st, data); if (*data <= 0xF0) { /* Single byte */ ret = *data; *atdata = data + 1; } else { /* Multibyte, little endian */ int nbytes = *data - 0xF0; ret = 0; if (nbytes > 8) janet_panic("invalid 64 bit integer"); MARSH_EOS(st, data + nbytes); for (int i = nbytes; i > 0; i--) ret = (ret << 8) + data[i]; *atdata = data + nbytes + 1; } return ret; } #ifdef JANET_MARSHAL_DEBUG static void dump_reference_table(UnmarshalState *st) { for (int32_t i = 0; i < janet_v_count(st->lookup); i++) { janet_eprintf(" reference %d (%t) = %v\n", i, st->lookup[i], st->lookup[i]); } } #endif /* Assert a janet type */ static void janet_asserttype(Janet x, JanetType t, UnmarshalState *st) { if (!janet_checktype(x, t)) { #ifdef JANET_MARSHAL_DEBUG dump_reference_table(st); #else (void) st; #endif janet_panicf("expected type %T, got %v", 1 << t, x); } } /* Forward declarations for mutual recursion */ static const uint8_t *unmarshal_one( UnmarshalState *st, const uint8_t *data, Janet *out, int flags); static const uint8_t *unmarshal_one_env( UnmarshalState *st, const uint8_t *data, JanetFuncEnv **out, int flags); static const uint8_t *unmarshal_one_def( UnmarshalState *st, const uint8_t *data, JanetFuncDef **out, int flags); static const uint8_t *unmarshal_one_fiber( UnmarshalState *st, const uint8_t *data, JanetFiber **out, int flags); /* Unmarshal a funcenv */ static const uint8_t *unmarshal_one_env( UnmarshalState *st, const uint8_t *data, JanetFuncEnv **out, int flags) { MARSH_EOS(st, data); if (*data == LB_FUNCENV_REF) { data++; int32_t index = readint(st, &data); if (index < 0 || index >= janet_v_count(st->lookup_envs)) janet_panicf("invalid funcenv reference %d", index); *out = st->lookup_envs[index]; } else { JanetFuncEnv *env = janet_gcalloc(JANET_MEMORY_FUNCENV, sizeof(JanetFuncEnv)); env->length = 0; env->offset = 0; env->as.values = NULL; janet_v_push(st->lookup_envs, env); int32_t offset = readnat(st, &data); int32_t length = readnat(st, &data); if (offset > 0) { Janet fiberv; /* On stack variant */ data = unmarshal_one(st, data, &fiberv, flags); janet_asserttype(fiberv, JANET_FIBER, st); env->as.fiber = janet_unwrap_fiber(fiberv); /* Negative offset indicates untrusted input */ env->offset = -offset; } else { /* Off stack variant */ if (length == 0) { janet_panic("invalid funcenv length"); } env->as.values = janet_malloc(sizeof(Janet) * (size_t) length); if (!env->as.values) { JANET_OUT_OF_MEMORY; } env->offset = 0; for (int32_t i = 0; i < length; i++) data = unmarshal_one(st, data, env->as.values + i, flags); } env->length = length; *out = env; } return data; } /* Unmarshal a series of u32s */ static const uint8_t *janet_unmarshal_u32s(UnmarshalState *st, const uint8_t *data, uint32_t *into, int32_t n) { for (int32_t i = 0; i < n; i++) { MARSH_EOS(st, data + 3); into[i] = (uint32_t)(data[0]) | ((uint32_t)(data[1]) << 8) | ((uint32_t)(data[2]) << 16) | ((uint32_t)(data[3]) << 24); data += 4; } return data; } /* Unmarshal a funcdef */ static const uint8_t *unmarshal_one_def( UnmarshalState *st, const uint8_t *data, JanetFuncDef **out, int flags) { MARSH_EOS(st, data); if (*data == LB_FUNCDEF_REF) { data++; int32_t index = readint(st, &data); if (index < 0 || index >= janet_v_count(st->lookup_defs)) janet_panicf("invalid funcdef reference %d", index); *out = st->lookup_defs[index]; } else { /* Initialize with values that will not break garbage collection * if unmarshalling fails. */ JanetFuncDef *def = janet_gcalloc(JANET_MEMORY_FUNCDEF, sizeof(JanetFuncDef)); def->environments_length = 0; def->defs_length = 0; def->constants_length = 0; def->bytecode_length = 0; def->name = NULL; def->source = NULL; def->closure_bitset = NULL; def->defs = NULL; def->environments = NULL; def->constants = NULL; def->bytecode = NULL; def->sourcemap = NULL; def->symbolmap = NULL; def->symbolmap_length = 0; def->named_args_count = 0; janet_v_push(st->lookup_defs, def); /* Set default lengths to zero */ int32_t bytecode_length = 0; int32_t constants_length = 0; int32_t environments_length = 0; int32_t defs_length = 0; int32_t symbolmap_length = 0; /* Read flags and other fixed values */ def->flags = readint(st, &data); def->slotcount = readnat(st, &data); def->arity = readnat(st, &data); def->min_arity = readnat(st, &data); def->max_arity = readnat(st, &data); /* Read some lengths */ constants_length = readnat(st, &data); bytecode_length = readnat(st, &data); if (def->flags & JANET_FUNCDEF_FLAG_NAMEDARGS) def->named_args_count = readnat(st, &data); if (def->flags & JANET_FUNCDEF_FLAG_HASENVS) environments_length = readnat(st, &data); if (def->flags & JANET_FUNCDEF_FLAG_HASDEFS) defs_length = readnat(st, &data); if (def->flags & JANET_FUNCDEF_FLAG_HASSYMBOLMAP) symbolmap_length = readnat(st, &data); /* Check name and source (optional) */ if (def->flags & JANET_FUNCDEF_FLAG_HASNAME) { Janet x; data = unmarshal_one(st, data, &x, flags + 1); janet_asserttype(x, JANET_STRING, st); def->name = janet_unwrap_string(x); } if (def->flags & JANET_FUNCDEF_FLAG_HASSOURCE) { Janet x; data = unmarshal_one(st, data, &x, flags + 1); janet_asserttype(x, JANET_STRING, st); def->source = janet_unwrap_string(x); } /* Unmarshal constants */ if (constants_length) { def->constants = janet_malloc(sizeof(Janet) * constants_length); if (!def->constants) { JANET_OUT_OF_MEMORY; } for (int32_t i = 0; i < constants_length; i++) data = unmarshal_one(st, data, def->constants + i, flags + 1); } else { def->constants = NULL; } def->constants_length = constants_length; /* Unmarshal symbol map, if needed */ if (def->flags & JANET_FUNCDEF_FLAG_HASSYMBOLMAP) { size_t size = sizeof(JanetSymbolMap) * symbolmap_length; def->symbolmap = janet_malloc(size); if (def->symbolmap == NULL) { JANET_OUT_OF_MEMORY; } for (int32_t i = 0; i < symbolmap_length; i++) { def->symbolmap[i].birth_pc = (uint32_t) readint(st, &data); def->symbolmap[i].death_pc = (uint32_t) readint(st, &data); def->symbolmap[i].slot_index = (uint32_t) readint(st, &data); Janet value; data = unmarshal_one(st, data, &value, flags + 1); if (!janet_checktype(value, JANET_SYMBOL)) { janet_panicf("corrupted symbolmap when unmarshalling debug info, got %v", value); } def->symbolmap[i].symbol = janet_unwrap_symbol(value); } def->symbolmap_length = (uint32_t) symbolmap_length; } /* Unmarshal bytecode */ def->bytecode = janet_malloc(sizeof(uint32_t) * bytecode_length); if (!def->bytecode) { JANET_OUT_OF_MEMORY; } data = janet_unmarshal_u32s(st, data, def->bytecode, bytecode_length); def->bytecode_length = bytecode_length; /* Unmarshal environments */ if (def->flags & JANET_FUNCDEF_FLAG_HASENVS) { def->environments = janet_calloc(1, sizeof(int32_t) * (size_t) environments_length); if (!def->environments) { JANET_OUT_OF_MEMORY; } for (int32_t i = 0; i < environments_length; i++) { def->environments[i] = readint(st, &data); } } else { def->environments = NULL; } def->environments_length = environments_length; /* Unmarshal sub funcdefs */ if (def->flags & JANET_FUNCDEF_FLAG_HASDEFS) { def->defs = janet_calloc(1, sizeof(JanetFuncDef *) * (size_t) defs_length); if (!def->defs) { JANET_OUT_OF_MEMORY; } for (int32_t i = 0; i < defs_length; i++) { data = unmarshal_one_def(st, data, def->defs + i, flags + 1); } } else { def->defs = NULL; } def->defs_length = defs_length; /* Unmarshal source maps if needed */ if (def->flags & JANET_FUNCDEF_FLAG_HASSOURCEMAP) { int32_t current = 0; def->sourcemap = janet_malloc(sizeof(JanetSourceMapping) * (size_t) bytecode_length); if (!def->sourcemap) { JANET_OUT_OF_MEMORY; } for (int32_t i = 0; i < bytecode_length; i++) { current += readint(st, &data); def->sourcemap[i].line = current; def->sourcemap[i].column = readint(st, &data); } } else { def->sourcemap = NULL; } /* Unmarshal closure bitset if needed */ if (def->flags & JANET_FUNCDEF_FLAG_HASCLOBITSET) { int32_t n = (def->slotcount + 31) >> 5; def->closure_bitset = janet_malloc(sizeof(uint32_t) * (size_t) n); if (NULL == def->closure_bitset) { JANET_OUT_OF_MEMORY; } data = janet_unmarshal_u32s(st, data, def->closure_bitset, n); } /* Validate */ if (janet_verify(def)) janet_panic("funcdef has invalid bytecode"); /* Set def */ *out = def; } return data; } /* Unmarshal a fiber */ static const uint8_t *unmarshal_one_fiber( UnmarshalState *st, const uint8_t *data, JanetFiber **out, int flags) { /* Initialize a new fiber with gc friendly defaults */ JanetFiber *fiber = janet_gcalloc(JANET_MEMORY_FIBER, sizeof(JanetFiber)); fiber->flags = 0; fiber->frame = 0; fiber->stackstart = 0; fiber->stacktop = 0; fiber->capacity = 0; fiber->maxstack = 0; fiber->data = NULL; fiber->child = NULL; fiber->env = NULL; fiber->last_value = janet_wrap_nil(); #ifdef JANET_EV fiber->sched_id = 0; fiber->supervisor_channel = NULL; fiber->ev_state = NULL; fiber->ev_callback = NULL; fiber->ev_stream = NULL; #endif /* Push fiber to seen stack */ janet_v_push(st->lookup, janet_wrap_fiber(fiber)); /* Read ints */ int32_t fiber_flags = readint(st, &data); int32_t frame = readnat(st, &data); int32_t fiber_stackstart = readnat(st, &data); int32_t fiber_stacktop = readnat(st, &data); int32_t fiber_maxstack = readnat(st, &data); JanetTable *fiber_env = NULL; /* Check for bad flags and ints */ if ((int32_t)(frame + JANET_FRAME_SIZE) > fiber_stackstart || fiber_stackstart > fiber_stacktop || fiber_stacktop > fiber_maxstack) { janet_panic("fiber has incorrect stack setup"); } /* Allocate stack memory */ fiber->capacity = fiber_stacktop + 10; fiber->data = janet_malloc(sizeof(Janet) * fiber->capacity); if (!fiber->data) { JANET_OUT_OF_MEMORY; } for (int32_t i = 0; i < fiber->capacity; i++) { fiber->data[i] = janet_wrap_nil(); } /* get frames */ int32_t stack = frame; int32_t stacktop = fiber_stackstart - JANET_FRAME_SIZE; while (stack > 0) { JanetFunction *func = NULL; JanetFuncDef *def = NULL; JanetFuncEnv *env = NULL; int32_t frameflags = readint(st, &data); int32_t prevframe = readnat(st, &data); int32_t pcdiff = readnat(st, &data); /* Get frame items */ Janet *framestack = fiber->data + stack; JanetStackFrame *framep = janet_stack_frame(framestack); /* Get function */ Janet funcv; data = unmarshal_one(st, data, &funcv, flags + 1); janet_asserttype(funcv, JANET_FUNCTION, st); func = janet_unwrap_function(funcv); def = func->def; /* Check env */ if (frameflags & JANET_STACKFRAME_HASENV) { frameflags &= ~JANET_STACKFRAME_HASENV; data = unmarshal_one_env(st, data, &env, flags + 1); } /* Error checking */ int32_t expected_framesize = def->slotcount; if (expected_framesize != stacktop - stack) { janet_panic("fiber stackframe size mismatch"); } if (pcdiff >= def->bytecode_length) { janet_panic("fiber stackframe has invalid pc"); } if ((int32_t)(prevframe + JANET_FRAME_SIZE) > stack) { janet_panic("fiber stackframe does not align with previous frame"); } /* Get stack items */ for (int32_t i = stack; i < stacktop; i++) data = unmarshal_one(st, data, fiber->data + i, flags + 1); /* Set frame */ framep->env = env; framep->pc = def->bytecode + pcdiff; framep->prevframe = prevframe; framep->flags = frameflags; framep->func = func; /* Goto previous frame */ stacktop = stack - JANET_FRAME_SIZE; stack = prevframe; } if (stack < 0) { janet_panic("fiber has too many stackframes"); } /* Check for fiber env */ if (fiber_flags & JANET_FIBER_FLAG_HASENV) { Janet envv; fiber_flags &= ~JANET_FIBER_FLAG_HASENV; data = unmarshal_one(st, data, &envv, flags + 1); janet_asserttype(envv, JANET_TABLE, st); fiber_env = janet_unwrap_table(envv); } /* Check for child fiber */ if (fiber_flags & JANET_FIBER_FLAG_HASCHILD) { Janet fiberv; fiber_flags &= ~JANET_FIBER_FLAG_HASCHILD; data = unmarshal_one(st, data, &fiberv, flags + 1); janet_asserttype(fiberv, JANET_FIBER, st); fiber->child = janet_unwrap_fiber(fiberv); } /* Get the fiber last value */ data = unmarshal_one(st, data, &fiber->last_value, flags + 1); /* We have valid fiber, finally construct remaining fields. */ fiber->frame = frame; fiber->flags = fiber_flags; fiber->stackstart = fiber_stackstart; fiber->stacktop = fiber_stacktop; fiber->maxstack = fiber_maxstack; fiber->env = fiber_env; int status = janet_fiber_status(fiber); if (status < 0 || status > JANET_STATUS_ALIVE) { janet_panic("invalid fiber status"); } /* Return data */ *out = fiber; return data; } void janet_unmarshal_ensure(JanetMarshalContext *ctx, size_t size) { UnmarshalState *st = (UnmarshalState *)(ctx->u_state); MARSH_EOS(st, ctx->data + size); } int32_t janet_unmarshal_int(JanetMarshalContext *ctx) { UnmarshalState *st = (UnmarshalState *)(ctx->u_state); return readint(st, &(ctx->data)); } size_t janet_unmarshal_size(JanetMarshalContext *ctx) { return (size_t) janet_unmarshal_int64(ctx); } int64_t janet_unmarshal_int64(JanetMarshalContext *ctx) { UnmarshalState *st = (UnmarshalState *)(ctx->u_state); return read64(st, &(ctx->data)); } void *janet_unmarshal_ptr(JanetMarshalContext *ctx) { if (!(ctx->flags & JANET_MARSHAL_UNSAFE)) { janet_panic("can only unmarshal pointers in unsafe mode"); } UnmarshalState *st = (UnmarshalState *)(ctx->u_state); void *ptr; MARSH_EOS(st, ctx->data + sizeof(void *) - 1); memcpy((char *) &ptr, ctx->data, sizeof(void *)); ctx->data += sizeof(void *); return ptr; } uint8_t janet_unmarshal_byte(JanetMarshalContext *ctx) { UnmarshalState *st = (UnmarshalState *)(ctx->u_state); MARSH_EOS(st, ctx->data); return *(ctx->data++); } void janet_unmarshal_bytes(JanetMarshalContext *ctx, uint8_t *dest, size_t len) { UnmarshalState *st = (UnmarshalState *)(ctx->u_state); MARSH_EOS(st, ctx->data + len - 1); safe_memcpy(dest, ctx->data, len); ctx->data += len; } Janet janet_unmarshal_janet(JanetMarshalContext *ctx) { Janet ret; UnmarshalState *st = (UnmarshalState *)(ctx->u_state); ctx->data = unmarshal_one(st, ctx->data, &ret, ctx->flags); return ret; } void janet_unmarshal_abstract_reuse(JanetMarshalContext *ctx, void *p) { UnmarshalState *st = (UnmarshalState *)(ctx->u_state); if (ctx->at == NULL) { janet_panicf("janet_unmarshal_abstract called more than once"); } janet_v_push(st->lookup, janet_wrap_abstract(p)); ctx->at = NULL; } void *janet_unmarshal_abstract(JanetMarshalContext *ctx, size_t size) { void *p = janet_abstract(ctx->at, size); janet_unmarshal_abstract_reuse(ctx, p); return p; } void *janet_unmarshal_abstract_threaded(JanetMarshalContext *ctx, size_t size) { #ifdef JANET_THREADS void *p = janet_abstract_threaded(ctx->at, size); janet_unmarshal_abstract_reuse(ctx, p); return p; #else (void) ctx; (void) size; janet_panic("threaded abstracts not supported"); #endif } static const uint8_t *unmarshal_one_abstract(UnmarshalState *st, const uint8_t *data, Janet *out, int flags) { Janet key; data = unmarshal_one(st, data, &key, flags + 1); const JanetAbstractType *at = janet_get_abstract_type(key); if (at == NULL) janet_panic("unknown abstract type"); if (at->unmarshal) { JanetMarshalContext context = {NULL, st, flags, data, at}; void *abst = at->unmarshal(&context); janet_assert(abst != NULL, "null pointer abstract"); *out = janet_wrap_abstract(abst); if (context.at != NULL) { janet_panic("janet_unmarshal_abstract not called"); } return context.data; } janet_panic("invalid abstract type - no unmarshal function pointer"); } static const uint8_t *unmarshal_one( UnmarshalState *st, const uint8_t *data, Janet *out, int flags) { uint8_t lead; MARSH_STACKCHECK; MARSH_EOS(st, data); lead = data[0]; if (lead < LB_REAL) { *out = janet_wrap_integer(readint(st, &data)); return data; } switch (lead) { case LB_NIL: *out = janet_wrap_nil(); return data + 1; case LB_FALSE: *out = janet_wrap_false(); return data + 1; case LB_TRUE: *out = janet_wrap_true(); return data + 1; case LB_INTEGER: /* Long integer */ MARSH_EOS(st, data + 4); uint32_t ui = ((uint32_t)(data[4])) | ((uint32_t)(data[3]) << 8) | ((uint32_t)(data[2]) << 16) | ((uint32_t)(data[1]) << 24); int32_t si = (int32_t)ui; *out = janet_wrap_integer(si); return data + 5; case LB_REAL: /* Real */ { union { double d; uint8_t bytes[8]; } u; MARSH_EOS(st, data + 8); #ifdef JANET_BIG_ENDIAN u.bytes[0] = data[8]; u.bytes[1] = data[7]; u.bytes[2] = data[6]; u.bytes[3] = data[5]; u.bytes[4] = data[4]; u.bytes[5] = data[3]; u.bytes[6] = data[2]; u.bytes[7] = data[1]; #else memcpy(&u.bytes, data + 1, sizeof(double)); #endif *out = janet_wrap_number_safe(u.d); janet_v_push(st->lookup, *out); return data + 9; } case LB_STRING: case LB_SYMBOL: case LB_BUFFER: case LB_KEYWORD: case LB_REGISTRY: { data++; int32_t len = readnat(st, &data); MARSH_EOS(st, data - 1 + len); if (lead == LB_STRING) { const uint8_t *str = janet_string(data, len); *out = janet_wrap_string(str); } else if (lead == LB_SYMBOL) { const uint8_t *str = janet_symbol(data, len); *out = janet_wrap_symbol(str); } else if (lead == LB_KEYWORD) { const uint8_t *str = janet_keyword(data, len); *out = janet_wrap_keyword(str); } else if (lead == LB_REGISTRY) { if (st->reg) { Janet regkey = janet_symbolv(data, len); *out = janet_table_get(st->reg, regkey); } else { *out = janet_wrap_nil(); } } else { /* (lead == LB_BUFFER) */ JanetBuffer *buffer = janet_buffer(len); buffer->count = len; safe_memcpy(buffer->data, data, len); *out = janet_wrap_buffer(buffer); } janet_v_push(st->lookup, *out); return data + len; } case LB_FIBER: { JanetFiber *fiber; data = unmarshal_one_fiber(st, data + 1, &fiber, flags + 1); *out = janet_wrap_fiber(fiber); return data; } case LB_FUNCTION: { JanetFunction *func; JanetFuncDef *def; data++; int32_t len = readnat(st, &data); if (len > 255) { janet_panicf("invalid function - too many environments (%d)", len); } func = janet_gcalloc(JANET_MEMORY_FUNCTION, sizeof(JanetFunction) + len * sizeof(JanetFuncEnv)); func->def = NULL; for (int32_t i = 0; i < len; i++) { func->envs[i] = NULL; } *out = janet_wrap_function(func); janet_v_push(st->lookup, *out); data = unmarshal_one_def(st, data, &def, flags + 1); func->def = def; for (int32_t i = 0; i < len; i++) { data = unmarshal_one_env(st, data, &(func->envs[i]), flags + 1); } return data; } case LB_ABSTRACT: { data++; return unmarshal_one_abstract(st, data, out, flags); } case LB_REFERENCE: case LB_ARRAY: case LB_ARRAY_WEAK: case LB_TUPLE: case LB_STRUCT: case LB_STRUCT_PROTO: case LB_TABLE: case LB_TABLE_PROTO: case LB_TABLE_WEAKK: case LB_TABLE_WEAKV: case LB_TABLE_WEAKKV: case LB_TABLE_WEAKK_PROTO: case LB_TABLE_WEAKV_PROTO: case LB_TABLE_WEAKKV_PROTO: /* Things that open with integers */ { data++; int32_t len = readnat(st, &data); /* DOS check */ if (lead != LB_REFERENCE) { MARSH_EOS(st, data - 1 + len); } if (lead == LB_ARRAY || lead == LB_ARRAY_WEAK) { /* Array */ JanetArray *array = (lead == LB_ARRAY_WEAK) ? janet_array_weak(len) : janet_array(len); array->count = len; *out = janet_wrap_array(array); janet_v_push(st->lookup, *out); for (int32_t i = 0; i < len; i++) { data = unmarshal_one(st, data, array->data + i, flags + 1); } } else if (lead == LB_TUPLE) { /* Tuple */ Janet *tup = janet_tuple_begin(len); int32_t flag = readint(st, &data); janet_tuple_flag(tup) |= flag << 16; for (int32_t i = 0; i < len; i++) { data = unmarshal_one(st, data, tup + i, flags + 1); } *out = janet_wrap_tuple(janet_tuple_end(tup)); janet_v_push(st->lookup, *out); } else if (lead == LB_STRUCT || lead == LB_STRUCT_PROTO) { /* Struct */ JanetKV *struct_ = janet_struct_begin(len); if (lead == LB_STRUCT_PROTO) { Janet proto; data = unmarshal_one(st, data, &proto, flags + 1); janet_asserttype(proto, JANET_STRUCT, st); janet_struct_proto(struct_) = janet_unwrap_struct(proto); } for (int32_t i = 0; i < len; i++) { Janet key, value; data = unmarshal_one(st, data, &key, flags + 1); data = unmarshal_one(st, data, &value, flags + 1); janet_struct_put(struct_, key, value); } *out = janet_wrap_struct(janet_struct_end(struct_)); janet_v_push(st->lookup, *out); } else if (lead == LB_REFERENCE) { if (len >= janet_v_count(st->lookup)) janet_panicf("invalid reference %d", len); *out = st->lookup[len]; } else { /* Table */ JanetTable *t; if (lead == LB_TABLE_WEAKK_PROTO || lead == LB_TABLE_WEAKK) { t = janet_table_weakk(len); } else if (lead == LB_TABLE_WEAKV_PROTO || lead == LB_TABLE_WEAKV) { t = janet_table_weakv(len); } else if (lead == LB_TABLE_WEAKKV_PROTO || lead == LB_TABLE_WEAKKV) { t = janet_table_weakkv(len); } else { t = janet_table(len); } *out = janet_wrap_table(t); janet_v_push(st->lookup, *out); if (lead == LB_TABLE_PROTO || lead == LB_TABLE_WEAKK_PROTO || lead == LB_TABLE_WEAKV_PROTO || lead == LB_TABLE_WEAKKV_PROTO) { Janet proto; data = unmarshal_one(st, data, &proto, flags + 1); janet_asserttype(proto, JANET_TABLE, st); t->proto = janet_unwrap_table(proto); } for (int32_t i = 0; i < len; i++) { Janet key, value; data = unmarshal_one(st, data, &key, flags + 1); data = unmarshal_one(st, data, &value, flags + 1); janet_table_put(t, key, value); } } return data; } case LB_UNSAFE_POINTER: { MARSH_EOS(st, data + sizeof(void *)); data++; if (!(flags & JANET_MARSHAL_UNSAFE)) { janet_panicf("unsafe flag not given, " "will not unmarshal raw pointer at index %d", (int)(data - st->start)); } union { void *ptr; uint8_t bytes[sizeof(void *)]; } u; memcpy(u.bytes, data, sizeof(void *)); data += sizeof(void *); *out = janet_wrap_pointer(u.ptr); janet_v_push(st->lookup, *out); return data; } #ifdef JANET_EV case LB_POINTER_BUFFER: { data++; int32_t count = readnat(st, &data); int32_t capacity = readnat(st, &data); MARSH_EOS(st, data + sizeof(void *)); union { void *ptr; uint8_t bytes[sizeof(void *)]; } u; if (!(flags & JANET_MARSHAL_UNSAFE)) { janet_panicf("unsafe flag not given, " "will not unmarshal raw pointer at index %d", (int)(data - st->start)); } memcpy(u.bytes, data, sizeof(void *)); data += sizeof(void *); JanetBuffer *buffer = janet_pointer_buffer_unsafe(u.ptr, capacity, count); *out = janet_wrap_buffer(buffer); janet_v_push(st->lookup, *out); return data; } #endif case LB_UNSAFE_CFUNCTION: { MARSH_EOS(st, data + sizeof(JanetCFunction)); data++; if (!(flags & JANET_MARSHAL_UNSAFE)) { janet_panicf("unsafe flag not given, " "will not unmarshal function pointer at index %d", (int)(data - st->start)); } union { JanetCFunction ptr; uint8_t bytes[sizeof(JanetCFunction)]; } u; memcpy(u.bytes, data, sizeof(JanetCFunction)); data += sizeof(JanetCFunction); *out = janet_wrap_cfunction(u.ptr); janet_v_push(st->lookup, *out); return data; } #ifdef JANET_EV case LB_THREADED_ABSTRACT: { MARSH_EOS(st, data + sizeof(void *)); data++; if (!(flags & JANET_MARSHAL_UNSAFE)) { janet_panicf("unsafe flag not given, " "will not unmarshal threaded abstract pointer at index %d", (int)(data - st->start)); } union { void *ptr; uint8_t bytes[sizeof(void *)]; } u; memcpy(u.bytes, data, sizeof(void *)); data += sizeof(void *); if (flags & JANET_MARSHAL_DECREF) { /* Decrement immediately and don't bother putting into heap */ janet_abstract_decref(u.ptr); *out = janet_wrap_nil(); } else { *out = janet_wrap_abstract(u.ptr); Janet check = janet_table_get(&janet_vm.threaded_abstracts, *out); if (janet_checktype(check, JANET_NIL)) { /* Transfers reference from threaded channel buffer to current heap */ janet_table_put(&janet_vm.threaded_abstracts, *out, janet_wrap_false()); } else { /* Heap reference already accounted for, remove threaded channel reference. */ janet_abstract_decref(u.ptr); } } janet_v_push(st->lookup, *out); return data; } #endif default: { janet_panicf("unknown byte %x at index %d", *data, (int)(data - st->start)); return NULL; } } } Janet janet_unmarshal( const uint8_t *bytes, size_t len, int flags, JanetTable *reg, const uint8_t **next) { UnmarshalState st; st.start = bytes; st.end = bytes + len; st.lookup_defs = NULL; st.lookup_envs = NULL; st.lookup = NULL; st.reg = reg; Janet out; const uint8_t *nextbytes = unmarshal_one(&st, bytes, &out, flags); if (next) *next = nextbytes; janet_v_free(st.lookup_defs); janet_v_free(st.lookup_envs); janet_v_free(st.lookup); return out; } /* C functions */ JANET_CORE_FN(cfun_env_lookup, "(env-lookup env)", "Creates a forward lookup table for unmarshalling from an environment. " "To create a reverse lookup table, use the invert function to swap keys " "and values in the returned table.") { janet_fixarity(argc, 1); JanetTable *env = janet_gettable(argv, 0); return janet_wrap_table(janet_env_lookup(env)); } JANET_CORE_FN(cfun_marshal, "(marshal x &opt reverse-lookup buffer no-cycles)", "Marshal a value into a buffer and return the buffer. The buffer " "can then later be unmarshalled to reconstruct the initial value. " "Optionally, one can pass in a reverse lookup table to not marshal " "aliased values that are found in the table. Then a forward " "lookup table can be used to recover the original value when " "unmarshalling.") { janet_arity(argc, 1, 4); JanetBuffer *buffer; JanetTable *rreg = NULL; uint32_t flags = 0; if (argc > 1) { rreg = janet_gettable(argv, 1); } if (argc > 2) { buffer = janet_getbuffer(argv, 2); } else { buffer = janet_buffer(10); } if (argc > 3 && janet_truthy(argv[3])) { flags |= JANET_MARSHAL_NO_CYCLES; } janet_marshal(buffer, argv[0], rreg, flags); return janet_wrap_buffer(buffer); } JANET_CORE_FN(cfun_unmarshal, "(unmarshal buffer &opt lookup)", "Unmarshal a value from a buffer. An optional lookup table " "can be provided to allow for aliases to be resolved. Returns the value " "unmarshalled from the buffer.") { janet_sandbox_assert(JANET_SANDBOX_UNMARSHAL); janet_arity(argc, 1, 2); JanetByteView view = janet_getbytes(argv, 0); JanetTable *reg = NULL; if (argc > 1) { reg = janet_gettable(argv, 1); } return janet_unmarshal(view.bytes, (size_t) view.len, 0, reg, NULL); } /* Module entry point */ void janet_lib_marsh(JanetTable *env) { JanetRegExt marsh_cfuns[] = { JANET_CORE_REG("marshal", cfun_marshal), JANET_CORE_REG("unmarshal", cfun_unmarshal), JANET_CORE_REG("env-lookup", cfun_env_lookup), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, marsh_cfuns); } janet-1.41.2/src/core/math.c000066400000000000000000000424071514534607600155360ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "state.h" #include "util.h" #endif #include static int janet_rng_get(void *p, Janet key, Janet *out); static Janet janet_rng_next(void *p, Janet key); static void janet_rng_marshal(void *p, JanetMarshalContext *ctx) { JanetRNG *rng = (JanetRNG *)p; janet_marshal_abstract(ctx, p); janet_marshal_int(ctx, (int32_t) rng->a); janet_marshal_int(ctx, (int32_t) rng->b); janet_marshal_int(ctx, (int32_t) rng->c); janet_marshal_int(ctx, (int32_t) rng->d); janet_marshal_int(ctx, (int32_t) rng->counter); } static void *janet_rng_unmarshal(JanetMarshalContext *ctx) { JanetRNG *rng = janet_unmarshal_abstract(ctx, sizeof(JanetRNG)); rng->a = (uint32_t) janet_unmarshal_int(ctx); rng->b = (uint32_t) janet_unmarshal_int(ctx); rng->c = (uint32_t) janet_unmarshal_int(ctx); rng->d = (uint32_t) janet_unmarshal_int(ctx); rng->counter = (uint32_t) janet_unmarshal_int(ctx); return rng; } const JanetAbstractType janet_rng_type = { "core/rng", NULL, NULL, janet_rng_get, NULL, janet_rng_marshal, janet_rng_unmarshal, NULL, /* tostring */ NULL, /* compare */ NULL, /* hash */ janet_rng_next, JANET_ATEND_NEXT }; JanetRNG *janet_default_rng(void) { return &janet_vm.rng; } void janet_rng_seed(JanetRNG *rng, uint32_t seed) { rng->a = seed; rng->b = 0x97654321u; rng->c = 123871873u; rng->d = 0xf23f56c8u; rng->counter = 0u; /* First several numbers aren't that random. */ for (int i = 0; i < 16; i++) janet_rng_u32(rng); } void janet_rng_longseed(JanetRNG *rng, const uint8_t *bytes, int32_t len) { uint8_t state[16] = {0}; for (int32_t i = 0; i < len; i++) state[i & 0xF] ^= bytes[i]; rng->a = state[0] + ((uint32_t) state[1] << 8) + ((uint32_t) state[2] << 16) + ((uint32_t) state[3] << 24); rng->b = state[4] + ((uint32_t) state[5] << 8) + ((uint32_t) state[6] << 16) + ((uint32_t) state[7] << 24); rng->c = state[8] + ((uint32_t) state[9] << 8) + ((uint32_t) state[10] << 16) + ((uint32_t) state[11] << 24); rng->d = state[12] + ((uint32_t) state[13] << 8) + ((uint32_t) state[14] << 16) + ((uint32_t) state[15] << 24); rng->counter = 0u; /* a, b, c, d can't all be 0 */ if (rng->a == 0) rng->a = 1u; for (int i = 0; i < 16; i++) janet_rng_u32(rng); } uint32_t janet_rng_u32(JanetRNG *rng) { /* Algorithm "xorwow" from p. 5 of Marsaglia, "Xorshift RNGs" */ uint32_t t = rng->d; uint32_t const s = rng->a; rng->d = rng->c; rng->c = rng->b; rng->b = s; t ^= t >> 2; t ^= t << 1; t ^= s ^ (s << 4); rng->a = t; rng->counter += 362437; return t + rng->counter; } double janet_rng_double(JanetRNG *rng) { uint32_t hi = janet_rng_u32(rng); uint32_t lo = janet_rng_u32(rng); uint64_t big = (uint64_t)(lo) | (((uint64_t) hi) << 32); return ldexp((double)(big >> (64 - 52)), -52); } JANET_CORE_FN(cfun_rng_make, "(math/rng &opt seed)", "Creates a Pseudo-Random number generator, with an optional seed. " "The seed should be an unsigned 32 bit integer or a buffer. " "Do not use this for cryptography. Returns a core/rng abstract type." ) { janet_arity(argc, 0, 1); JanetRNG *rng = janet_abstract(&janet_rng_type, sizeof(JanetRNG)); if (argc == 1) { if (janet_checkint(argv[0])) { uint32_t seed = (uint32_t)(janet_getinteger(argv, 0)); janet_rng_seed(rng, seed); } else { JanetByteView bytes = janet_getbytes(argv, 0); janet_rng_longseed(rng, bytes.bytes, bytes.len); } } else { janet_rng_seed(rng, 0); } return janet_wrap_abstract(rng); } JANET_CORE_FN(cfun_rng_uniform, "(math/rng-uniform rng)", "Extract a random number in the range [0, 1) from the RNG." ) { janet_fixarity(argc, 1); JanetRNG *rng = janet_getabstract(argv, 0, &janet_rng_type); return janet_wrap_number(janet_rng_double(rng)); } JANET_CORE_FN(cfun_rng_int, "(math/rng-int rng &opt max)", "Extract a random integer in the range [0, max) for max > 0 from the RNG. " "If max is 0, return 0. If no max is given, the default is 2^31 - 1." ) { janet_arity(argc, 1, 2); JanetRNG *rng = janet_getabstract(argv, 0, &janet_rng_type); if (argc == 1) { uint32_t word = janet_rng_u32(rng) >> 1; return janet_wrap_integer(word); } else { int32_t max = janet_optnat(argv, argc, 1, INT32_MAX); if (max == 0) return janet_wrap_number(0.0); uint32_t modulo = (uint32_t) max; uint32_t maxgen = INT32_MAX; uint32_t maxword = maxgen - (maxgen % modulo); uint32_t word; do { word = janet_rng_u32(rng) >> 1; } while (word > maxword); return janet_wrap_integer(word % modulo); } } static void rng_get_4bytes(JanetRNG *rng, uint8_t *buf) { uint32_t word = janet_rng_u32(rng); buf[0] = word & 0xFF; buf[1] = (word >> 8) & 0xFF; buf[2] = (word >> 16) & 0xFF; buf[3] = (word >> 24) & 0xFF; } JANET_CORE_FN(cfun_rng_buffer, "(math/rng-buffer rng n &opt buf)", "Get n random bytes and put them in a buffer. Creates a new buffer if no buffer is " "provided, otherwise appends to the given buffer. Returns the buffer." ) { janet_arity(argc, 2, 3); JanetRNG *rng = janet_getabstract(argv, 0, &janet_rng_type); int32_t n = janet_getnat(argv, 1); JanetBuffer *buffer = janet_optbuffer(argv, argc, 2, n); /* Split into first part (that is divisible by 4), and rest */ int32_t first_part = n & ~3; int32_t second_part = n - first_part; /* Get first part in chunks of 4 bytes */ janet_buffer_extra(buffer, n); uint8_t *buf = buffer->data + buffer->count; for (int32_t i = 0; i < first_part; i += 4) rng_get_4bytes(rng, buf + i); buffer->count += first_part; /* Get remaining 0 - 3 bytes */ if (second_part) { uint8_t wordbuf[4] = {0}; rng_get_4bytes(rng, wordbuf); janet_buffer_push_bytes(buffer, wordbuf, second_part); } return janet_wrap_buffer(buffer); } static const JanetMethod rng_methods[] = { {"uniform", cfun_rng_uniform}, {"int", cfun_rng_int}, {"buffer", cfun_rng_buffer}, {NULL, NULL} }; static int janet_rng_get(void *p, Janet key, Janet *out) { (void) p; if (!janet_checktype(key, JANET_KEYWORD)) return 0; return janet_getmethod(janet_unwrap_keyword(key), rng_methods, out); } static Janet janet_rng_next(void *p, Janet key) { (void) p; return janet_nextmethod(rng_methods, key); } /* Get a random number */ JANET_CORE_FN(janet_rand, "(math/random)", "Returns a uniformly distributed random number between 0 and 1.") { (void) argv; janet_fixarity(argc, 0); return janet_wrap_number(janet_rng_double(&janet_vm.rng)); } /* Seed the random number generator */ JANET_CORE_FN(janet_srand, "(math/seedrandom seed)", "Set the seed for the random number generator. `seed` should be " "an integer or a buffer." ) { janet_fixarity(argc, 1); if (janet_checkint(argv[0])) { uint32_t seed = (uint32_t)(janet_getinteger(argv, 0)); janet_rng_seed(&janet_vm.rng, seed); } else { JanetByteView bytes = janet_getbytes(argv, 0); janet_rng_longseed(&janet_vm.rng, bytes.bytes, bytes.len); } return janet_wrap_nil(); } #define JANET_DEFINE_NAMED_MATHOP(janet_name, fop, doc)\ JANET_CORE_FN(janet_##fop, "(math/" janet_name " x)", doc) {\ janet_fixarity(argc, 1); \ double x = janet_getnumber(argv, 0); \ return janet_wrap_number(fop(x)); \ } #define JANET_DEFINE_MATHOP(fop, doc) JANET_DEFINE_NAMED_MATHOP(#fop, fop, doc) JANET_DEFINE_MATHOP(acos, "Returns the arccosine of x.") JANET_DEFINE_MATHOP(asin, "Returns the arcsin of x.") JANET_DEFINE_MATHOP(atan, "Returns the arctangent of x.") JANET_DEFINE_MATHOP(cos, "Returns the cosine of x.") JANET_DEFINE_MATHOP(cosh, "Returns the hyperbolic cosine of x.") JANET_DEFINE_MATHOP(acosh, "Returns the hyperbolic arccosine of x.") JANET_DEFINE_MATHOP(sin, "Returns the sine of x.") JANET_DEFINE_MATHOP(sinh, "Returns the hyperbolic sine of x.") JANET_DEFINE_MATHOP(tan, "Returns the tangent of x.") JANET_DEFINE_MATHOP(tanh, "Returns the hyperbolic tangent of x.") JANET_DEFINE_MATHOP(exp, "Returns e to the power of x.") JANET_DEFINE_MATHOP(exp2, "Returns 2 to the power of x.") JANET_DEFINE_MATHOP(log1p, "Returns (log base e of x) + 1 more accurately than (+ (math/log x) 1)") #ifndef JANET_PLAN9 JANET_DEFINE_MATHOP(expm1, "Returns e to the power of x minus 1.") JANET_DEFINE_MATHOP(cbrt, "Returns the cube root of x.") JANET_DEFINE_MATHOP(erf, "Returns the error function of x.") JANET_DEFINE_MATHOP(erfc, "Returns the complementary error function of x.") JANET_DEFINE_NAMED_MATHOP("log-gamma", lgamma, "Returns log-gamma(x).") JANET_DEFINE_NAMED_MATHOP("gamma", tgamma, "Returns gamma(x).") JANET_DEFINE_MATHOP(atanh, "Returns the hyperbolic arctangent of x.") JANET_DEFINE_MATHOP(asinh, "Returns the hyperbolic arcsine of x.") #endif JANET_DEFINE_MATHOP(log, "Returns the natural logarithm of x.") JANET_DEFINE_MATHOP(log10, "Returns the log base 10 of x.") JANET_DEFINE_MATHOP(log2, "Returns the log base 2 of x.") JANET_DEFINE_MATHOP(sqrt, "Returns the square root of x.") JANET_DEFINE_MATHOP(ceil, "Returns the smallest integer value number that is not less than x.") JANET_DEFINE_MATHOP(floor, "Returns the largest integer value number that is not greater than x.") JANET_DEFINE_MATHOP(trunc, "Returns the integer between x and 0 nearest to x.") JANET_DEFINE_MATHOP(round, "Returns the integer nearest to x.") JANET_DEFINE_NAMED_MATHOP("abs", fabs, "Return the absolute value of x.") #define JANET_DEFINE_MATH2OP(name, fop, signature, doc)\ JANET_CORE_FN(janet_##name, signature, doc) {\ janet_fixarity(argc, 2); \ double lhs = janet_getnumber(argv, 0); \ double rhs = janet_getnumber(argv, 1); \ return janet_wrap_number(fop(lhs, rhs)); \ } JANET_DEFINE_MATH2OP(atan2, atan2, "(math/atan2 y x)", "Returns the arctangent of y/x. Works even when x is 0.") JANET_DEFINE_MATH2OP(pow, pow, "(math/pow a x)", "Returns a to the power of x.") JANET_DEFINE_MATH2OP(hypot, hypot, "(math/hypot a b)", "Returns c from the equation c^2 = a^2 + b^2.") #ifndef JANET_PLAN9 JANET_DEFINE_MATH2OP(nextafter, nextafter, "(math/next x y)", "Returns the next representable floating point value after x in the direction of y.") #endif JANET_CORE_FN(janet_not, "(not x)", "Returns the boolean inverse of x.") { janet_fixarity(argc, 1); return janet_wrap_boolean(!janet_truthy(argv[0])); } static double janet_gcd(double x, double y) { if (isnan(x) || isnan(y)) { #ifdef NAN return NAN; #else return 0.0 / 0.0; #endif } if (isinf(x) || isinf(y)) return INFINITY; while (y != 0) { double temp = y; y = fmod(x, y); x = temp; } return x; } static double janet_lcm(double x, double y) { return (x / janet_gcd(x, y)) * y; } JANET_CORE_FN(janet_cfun_gcd, "(math/gcd x y)", "Returns the greatest common divisor between x and y.") { janet_fixarity(argc, 2); double x = janet_getnumber(argv, 0); double y = janet_getnumber(argv, 1); return janet_wrap_number(janet_gcd(x, y)); } JANET_CORE_FN(janet_cfun_lcm, "(math/lcm x y)", "Returns the least common multiple of x and y.") { janet_fixarity(argc, 2); double x = janet_getnumber(argv, 0); double y = janet_getnumber(argv, 1); return janet_wrap_number(janet_lcm(x, y)); } JANET_CORE_FN(janet_cfun_frexp, "(math/frexp x)", "Returns a tuple of (mantissa, exponent) from number.") { janet_fixarity(argc, 1); double x = janet_getnumber(argv, 0); int exp; x = frexp(x, &exp); Janet *result = janet_tuple_begin(2); result[0] = janet_wrap_number(x); result[1] = janet_wrap_number((double) exp); return janet_wrap_tuple(janet_tuple_end(result)); } JANET_CORE_FN(janet_cfun_ldexp, "(math/ldexp m e)", "Creates a new number from a mantissa and an exponent.") { janet_fixarity(argc, 2); double x = janet_getnumber(argv, 0); int32_t y = janet_getinteger(argv, 1); return janet_wrap_number(ldexp(x, y)); } /* Module entry point */ void janet_lib_math(JanetTable *env) { JanetRegExt math_cfuns[] = { JANET_CORE_REG("not", janet_not), JANET_CORE_REG("math/random", janet_rand), JANET_CORE_REG("math/seedrandom", janet_srand), JANET_CORE_REG("math/cos", janet_cos), JANET_CORE_REG("math/sin", janet_sin), JANET_CORE_REG("math/tan", janet_tan), JANET_CORE_REG("math/acos", janet_acos), JANET_CORE_REG("math/asin", janet_asin), JANET_CORE_REG("math/atan", janet_atan), JANET_CORE_REG("math/exp", janet_exp), JANET_CORE_REG("math/log", janet_log), JANET_CORE_REG("math/log10", janet_log10), JANET_CORE_REG("math/log2", janet_log2), JANET_CORE_REG("math/sqrt", janet_sqrt), #ifndef JANET_PLAN9 JANET_CORE_REG("math/cbrt", janet_cbrt), JANET_CORE_REG("math/gamma", janet_tgamma), JANET_CORE_REG("math/log-gamma", janet_lgamma), JANET_CORE_REG("math/erfc", janet_erfc), JANET_CORE_REG("math/erf", janet_erf), JANET_CORE_REG("math/expm1", janet_expm1), JANET_CORE_REG("math/atanh", janet_atanh), JANET_CORE_REG("math/asinh", janet_asinh), JANET_CORE_REG("math/next", janet_nextafter), #endif JANET_CORE_REG("math/floor", janet_floor), JANET_CORE_REG("math/ceil", janet_ceil), JANET_CORE_REG("math/pow", janet_pow), JANET_CORE_REG("math/abs", janet_fabs), JANET_CORE_REG("math/sinh", janet_sinh), JANET_CORE_REG("math/cosh", janet_cosh), JANET_CORE_REG("math/tanh", janet_tanh), JANET_CORE_REG("math/acosh", janet_acosh), JANET_CORE_REG("math/atan2", janet_atan2), JANET_CORE_REG("math/rng", cfun_rng_make), JANET_CORE_REG("math/rng-uniform", cfun_rng_uniform), JANET_CORE_REG("math/rng-int", cfun_rng_int), JANET_CORE_REG("math/rng-buffer", cfun_rng_buffer), JANET_CORE_REG("math/hypot", janet_hypot), JANET_CORE_REG("math/exp2", janet_exp2), JANET_CORE_REG("math/log1p", janet_log1p), JANET_CORE_REG("math/trunc", janet_trunc), JANET_CORE_REG("math/round", janet_round), JANET_CORE_REG("math/gcd", janet_cfun_gcd), JANET_CORE_REG("math/lcm", janet_cfun_lcm), JANET_CORE_REG("math/frexp", janet_cfun_frexp), JANET_CORE_REG("math/ldexp", janet_cfun_ldexp), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, math_cfuns); janet_register_abstract_type(&janet_rng_type); #ifdef JANET_BOOTSTRAP JANET_CORE_DEF(env, "math/pi", janet_wrap_number(3.1415926535897931), "The value pi."); JANET_CORE_DEF(env, "math/e", janet_wrap_number(2.7182818284590451), "The base of the natural log."); JANET_CORE_DEF(env, "math/inf", janet_wrap_number(INFINITY), "The number representing positive infinity"); JANET_CORE_DEF(env, "math/-inf", janet_wrap_number(-INFINITY), "The number representing negative infinity"); JANET_CORE_DEF(env, "math/int32-min", janet_wrap_number(INT32_MIN), "The minimum contiguous integer representable by a 32 bit signed integer"); JANET_CORE_DEF(env, "math/int32-max", janet_wrap_number(INT32_MAX), "The maximum contiguous integer representable by a 32 bit signed integer"); JANET_CORE_DEF(env, "math/int-min", janet_wrap_number(JANET_INTMIN_DOUBLE), "The minimum contiguous integer representable by a double (-(2^53))"); JANET_CORE_DEF(env, "math/int-max", janet_wrap_number(JANET_INTMAX_DOUBLE), "The maximum contiguous integer representable by a double (2^53)"); #ifdef NAN JANET_CORE_DEF(env, "math/nan", janet_wrap_number(NAN), "Not a number (IEEE-754 NaN)"); #else JANET_CORE_DEF(env, "math/nan", janet_wrap_number(0.0 / 0.0), "Not a number (IEEE-754 NaN)"); #endif #endif } janet-1.41.2/src/core/net.c000066400000000000000000001313631514534607600153730ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose and contributors. * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "util.h" #include "fiber.h" #endif #ifdef JANET_NET #include #ifdef JANET_WINDOWS #include #include #include #include #ifdef JANET_MSVC #pragma comment (lib, "Ws2_32.lib") #pragma comment (lib, "Mswsock.lib") #pragma comment (lib, "Advapi32.lib") #endif #else #include #include #include #include #include #include #include #include #include #include #include #endif const JanetAbstractType janet_address_type = { "core/socket-address", JANET_ATEND_NAME }; #ifdef JANET_WINDOWS #define JSOCKCLOSE(x) closesocket((SOCKET) x) #define JSOCKDEFAULT INVALID_SOCKET #define JSOCKVALID(x) ((x) != INVALID_SOCKET) #define JSock SOCKET #define JSOCKFLAGS 0 #else #define JSOCKCLOSE(x) close(x) #define JSOCKDEFAULT 0 #define JSOCKVALID(x) ((x) >= 0) #define JSock int #ifdef SOCK_CLOEXEC #define JSOCKFLAGS SOCK_CLOEXEC #else #define JSOCKFLAGS 0 #endif #endif /* maximum number of bytes in a socket address host (post name resolution) */ #ifdef JANET_WINDOWS #ifdef JANET_NO_IPV6 #define SA_ADDRSTRLEN (INET_ADDRSTRLEN + 1) #else #define SA_ADDRSTRLEN (INET6_ADDRSTRLEN + 1) #endif typedef unsigned short in_port_t; #else #define JANET_SA_MAX(a, b) (((a) > (b))? (a) : (b)) #ifdef JANET_NO_IPV6 #define SA_ADDRSTRLEN JANET_SA_MAX(INET_ADDRSTRLEN + 1, (sizeof ((struct sockaddr_un *)0)->sun_path) + 1) #else #define SA_ADDRSTRLEN JANET_SA_MAX(INET6_ADDRSTRLEN + 1, (sizeof ((struct sockaddr_un *)0)->sun_path) + 1) #endif #endif static JanetStream *make_stream(JSock handle, uint32_t flags); /* We pass this flag to all send calls to prevent sigpipe */ #ifndef MSG_NOSIGNAL #define MSG_NOSIGNAL 0 #endif /* Make sure a socket doesn't block */ static void janet_net_socknoblock(JSock s) { #ifdef JANET_WINDOWS unsigned long arg = 1; ioctlsocket(s, FIONBIO, &arg); #else #if !defined(SOCK_CLOEXEC) && defined(O_CLOEXEC) int extra = O_CLOEXEC; #else int extra = 0; #endif fcntl(s, F_SETFL, fcntl(s, F_GETFL, 0) | O_NONBLOCK | extra); #ifdef SO_NOSIGPIPE int enable = 1; setsockopt(s, SOL_SOCKET, SO_NOSIGPIPE, &enable, sizeof(int)); #endif #endif } /* Allow specifying IPV6 vs. IPV4 (or unix domain socket) */ static int net_get_address_family(Janet x) { if (janet_checktype(x, JANET_NIL)) { return AF_UNSPEC; } if (janet_keyeq(x, "ipv4")) { return AF_INET; } if (janet_keyeq(x, "ipv6")) { return AF_INET6; } #ifndef JANET_WINDOWS if (janet_keyeq(x, "unix")) { return AF_UNIX; } #endif return AF_UNSPEC; } /* State machine for async connect */ void net_callback_connect(JanetFiber *fiber, JanetAsyncEvent event) { JanetStream *stream = fiber->ev_stream; switch (event) { default: break; #ifndef JANET_WINDOWS /* Wait until we have an actual event before checking. * Windows doesn't support async connect with this, just try immediately.*/ case JANET_ASYNC_EVENT_INIT: #endif case JANET_ASYNC_EVENT_DEINIT: return; case JANET_ASYNC_EVENT_CLOSE: janet_cancel(fiber, janet_cstringv("stream closed")); janet_async_end(fiber); return; } #ifdef JANET_WINDOWS int res = 0; int size = sizeof(res); int r = getsockopt((SOCKET)stream->handle, SOL_SOCKET, SO_ERROR, (char *)&res, &size); #else int res = 0; socklen_t size = sizeof res; int r = getsockopt(stream->handle, SOL_SOCKET, SO_ERROR, &res, &size); #endif if (r == 0) { if (res == 0) { janet_schedule(fiber, janet_wrap_abstract(stream)); } else { janet_cancel(fiber, janet_cstringv(janet_strerror(res))); stream->flags |= JANET_STREAM_TOCLOSE; } } else { janet_cancel(fiber, janet_ev_lasterr()); stream->flags |= JANET_STREAM_TOCLOSE; } janet_async_end(fiber); } static JANET_NO_RETURN void net_sched_connect(JanetStream *stream) { janet_async_start(stream, JANET_ASYNC_LISTEN_WRITE, net_callback_connect, NULL); } /* State machine for accepting connections. */ #ifdef JANET_WINDOWS typedef struct { WSAOVERLAPPED overlapped; JanetFunction *function; JanetStream *lstream; JanetStream *astream; char buf[1024]; } NetStateAccept; static int net_sched_accept_impl(NetStateAccept *state, JanetFiber *fiber, Janet *err); void net_callback_accept(JanetFiber *fiber, JanetAsyncEvent event) { NetStateAccept *state = (NetStateAccept *)fiber->ev_state; switch (event) { default: break; case JANET_ASYNC_EVENT_MARK: { if (state->lstream) janet_mark(janet_wrap_abstract(state->lstream)); if (state->astream) janet_mark(janet_wrap_abstract(state->astream)); if (state->function) janet_mark(janet_wrap_function(state->function)); break; } case JANET_ASYNC_EVENT_CLOSE: janet_schedule(fiber, janet_wrap_nil()); janet_async_end(fiber); return; case JANET_ASYNC_EVENT_COMPLETE: { if (state->astream->flags & JANET_STREAM_CLOSED) { janet_cancel(fiber, janet_cstringv("failed to accept connection")); janet_async_end(fiber); return; } SOCKET lsock = (SOCKET) state->lstream->handle; if (NO_ERROR != setsockopt((SOCKET) state->astream->handle, SOL_SOCKET, SO_UPDATE_ACCEPT_CONTEXT, (char *) &lsock, sizeof(lsock))) { janet_cancel(fiber, janet_cstringv("failed to accept connection")); janet_async_end(fiber); return; } Janet streamv = janet_wrap_abstract(state->astream); if (state->function) { /* Schedule worker */ JanetFiber *sub_fiber = janet_fiber(state->function, 64, 1, &streamv); sub_fiber->supervisor_channel = fiber->supervisor_channel; janet_schedule(sub_fiber, janet_wrap_nil()); /* Now listen again for next connection */ Janet err; if (net_sched_accept_impl(state, fiber, &err)) { janet_cancel(fiber, err); janet_async_end(fiber); return; } } else { janet_schedule(fiber, streamv); janet_async_end(fiber); return; } } } } JANET_NO_RETURN static void janet_sched_accept(JanetStream *stream, JanetFunction *fun) { Janet err; NetStateAccept *state = janet_malloc(sizeof(NetStateAccept)); memset(&state->overlapped, 0, sizeof(WSAOVERLAPPED)); memset(&state->buf, 0, 1024); state->function = fun; state->lstream = stream; if (net_sched_accept_impl(state, janet_root_fiber(), &err)) { janet_free(state); janet_panicv(err); } janet_async_start(stream, JANET_ASYNC_LISTEN_READ, net_callback_accept, state); } static int net_sched_accept_impl(NetStateAccept *state, JanetFiber *fiber, Janet *err) { SOCKET lsock = (SOCKET) state->lstream->handle; SOCKET asock = WSASocketW(AF_INET, SOCK_STREAM, IPPROTO_TCP, NULL, 0, WSA_FLAG_OVERLAPPED); if (asock == INVALID_SOCKET) { *err = janet_ev_lasterr(); return 1; } JanetStream *astream = make_stream(asock, JANET_STREAM_READABLE | JANET_STREAM_WRITABLE); state->astream = astream; int socksize = sizeof(SOCKADDR_STORAGE) + 16; if (FALSE == AcceptEx(lsock, asock, state->buf, 0, socksize, socksize, NULL, &state->overlapped)) { int code = WSAGetLastError(); if (code == WSA_IO_PENDING) { /* indicates io is happening async */ janet_async_in_flight(fiber); return 0; } *err = janet_ev_lasterr(); return 1; } return 0; } #else typedef struct { JanetFunction *function; } NetStateAccept; void net_callback_accept(JanetFiber *fiber, JanetAsyncEvent event) { JanetStream *stream = fiber->ev_stream; NetStateAccept *state = (NetStateAccept *)fiber->ev_state; switch (event) { default: break; case JANET_ASYNC_EVENT_MARK: { if (state->function) janet_mark(janet_wrap_function(state->function)); break; } case JANET_ASYNC_EVENT_CLOSE: janet_schedule(fiber, janet_wrap_nil()); janet_async_end(fiber); return; case JANET_ASYNC_EVENT_INIT: case JANET_ASYNC_EVENT_READ: { #if defined(JANET_LINUX) JSock connfd = accept4(stream->handle, NULL, NULL, SOCK_CLOEXEC); #else /* On BSDs, CLOEXEC should be inherited from server socket */ JSock connfd = accept(stream->handle, NULL, NULL); #endif if (JSOCKVALID(connfd)) { janet_net_socknoblock(connfd); JanetStream *stream = make_stream(connfd, JANET_STREAM_READABLE | JANET_STREAM_WRITABLE); Janet streamv = janet_wrap_abstract(stream); if (state->function) { JanetFiber *sub_fiber = janet_fiber(state->function, 64, 1, &streamv); sub_fiber->supervisor_channel = fiber->supervisor_channel; janet_schedule(sub_fiber, janet_wrap_nil()); } else { janet_schedule(fiber, streamv); janet_async_end(fiber); return; } } break; } } } JANET_NO_RETURN static void janet_sched_accept(JanetStream *stream, JanetFunction *fun) { NetStateAccept *state = janet_malloc(sizeof(NetStateAccept)); memset(state, 0, sizeof(NetStateAccept)); state->function = fun; if (fun) janet_stream_level_triggered(stream); janet_async_start(stream, JANET_ASYNC_LISTEN_READ, net_callback_accept, state); } #endif /* Address info */ static int janet_get_sockettype(Janet *argv, int32_t argc, int32_t n) { JanetKeyword stype = janet_optkeyword(argv, argc, n, NULL); int socktype = SOCK_DGRAM; if ((NULL == stype) || !janet_cstrcmp(stype, "stream")) { socktype = SOCK_STREAM; } else if (janet_cstrcmp(stype, "datagram")) { janet_panicf("expected socket type as :stream or :datagram, got %v", argv[n]); } return socktype; } /* Needs argc >= offset + 2 */ /* For unix paths, just rertuns a single sockaddr and sets *is_unix to 1, * otherwise 0. Also, ignores is_bind when is a unix socket. */ static struct addrinfo *janet_get_addrinfo(Janet *argv, int32_t offset, int socktype, int passive, int *is_unix, socklen_t *sizeout) { /* Unix socket support - not yet supported on windows. */ #ifndef JANET_WINDOWS if (janet_keyeq(argv[offset], "unix")) { const char *path = janet_getcstring(argv, offset + 1); struct sockaddr_un *saddr = janet_calloc(1, sizeof(struct sockaddr_un)); if (saddr == NULL) { JANET_OUT_OF_MEMORY; } saddr->sun_family = AF_UNIX; size_t path_size = sizeof(saddr->sun_path); snprintf(saddr->sun_path, path_size, "%s", path); *sizeout = sizeof(struct sockaddr_un); #ifdef JANET_LINUX if (path[0] == '@') { saddr->sun_path[0] = '\0'; *sizeout = offsetof(struct sockaddr_un, sun_path) + janet_string_length(path); } #endif *is_unix = 1; return (struct addrinfo *) saddr; } #endif /* Get host and port */ char *host = (char *)janet_getcstring(argv, offset); char *port = NULL; if (janet_checkint(argv[offset + 1])) { port = (char *)janet_to_string(argv[offset + 1]); } else { port = (char *)janet_optcstring(argv, offset + 2, offset + 1, NULL); } /* getaddrinfo */ struct addrinfo *ai = NULL; struct addrinfo hints; memset(&hints, 0, sizeof(hints)); hints.ai_family = AF_UNSPEC; hints.ai_socktype = socktype; hints.ai_flags = passive ? AI_PASSIVE : 0; int status = getaddrinfo(host, port, &hints, &ai); if (status) { janet_panicf("could not get address info: %s", gai_strerror(status)); } *is_unix = 0; #ifdef JANET_WINDOWS *sizeout = 0; #else *sizeout = sizeof(struct sockaddr_un); #endif return ai; } /* * C Funs */ JANET_CORE_FN(cfun_net_sockaddr, "(net/address host port &opt type multi)", "Look up the connection information for a given hostname, port, and connection type. Returns " "a handle that can be used to send datagrams over network without establishing a connection. " "On Posix platforms, you can use :unix for host to connect to a unix domain socket, where the name is " "given in the port argument. On Linux, abstract " "unix domain sockets are specified with a leading '@' character in port. If `multi` is truthy, will " "return all address that match in an array instead of just the first.") { janet_sandbox_assert(JANET_SANDBOX_NET_CONNECT); /* connect OR listen */ janet_arity(argc, 2, 4); int socktype = janet_get_sockettype(argv, argc, 2); int is_unix = 0; int make_arr = (argc >= 3 && janet_truthy(argv[3])); socklen_t addrsize = 0; struct addrinfo *ai = janet_get_addrinfo(argv, 0, socktype, 0, &is_unix, &addrsize); #ifndef JANET_WINDOWS /* no unix domain socket support on windows yet */ if (is_unix) { void *abst = janet_abstract(&janet_address_type, addrsize); memcpy(abst, ai, addrsize); Janet ret = janet_wrap_abstract(abst); return make_arr ? janet_wrap_array(janet_array_n(&ret, 1)) : ret; } #endif if (make_arr) { /* Select all */ JanetArray *arr = janet_array(10); struct addrinfo *iter = ai; while (NULL != iter) { void *abst = janet_abstract(&janet_address_type, iter->ai_addrlen); memcpy(abst, iter->ai_addr, iter->ai_addrlen); janet_array_push(arr, janet_wrap_abstract(abst)); iter = iter->ai_next; } freeaddrinfo(ai); return janet_wrap_array(arr); } else { /* Select first */ if (NULL == ai) { janet_panic("no data for given address"); } void *abst = janet_abstract(&janet_address_type, ai->ai_addrlen); memcpy(abst, ai->ai_addr, ai->ai_addrlen); freeaddrinfo(ai); return janet_wrap_abstract(abst); } } JANET_CORE_FN(cfun_net_connect, "(net/connect host port &opt type bindhost bindport)", "Open a connection to communicate with a server. Returns a duplex stream " "that can be used to communicate with the server. Type is an optional keyword " "to specify a connection type, either :stream or :datagram. The default is :stream. " "Bindhost is an optional string to select from what address to make the outgoing " "connection, with the default being the same as using the OS's preferred address. ") { janet_sandbox_assert(JANET_SANDBOX_NET_CONNECT); janet_arity(argc, 2, 5); /* Check arguments */ int socktype = janet_get_sockettype(argv, argc, 2); int is_unix = 0; char *bindhost = (char *) janet_optcstring(argv, argc, 3, NULL); char *bindport = NULL; if (argc >= 5 && janet_checkint(argv[4])) { bindport = (char *)janet_to_string(argv[4]); } else { bindport = (char *)janet_optcstring(argv, argc, 4, NULL); } /* Where we're connecting to */ socklen_t addrlen = 0; struct addrinfo *ai = janet_get_addrinfo(argv, 0, socktype, 0, &is_unix, &addrlen); /* Check if we're binding address */ struct addrinfo *binding = NULL; if (bindhost != NULL) { if (is_unix) { freeaddrinfo(ai); janet_panic("bindhost not supported for unix domain sockets"); } /* getaddrinfo */ struct addrinfo hints; memset(&hints, 0, sizeof(hints)); hints.ai_family = AF_UNSPEC; hints.ai_socktype = socktype; hints.ai_flags = 0; int status = getaddrinfo(bindhost, bindport, &hints, &binding); if (status) { freeaddrinfo(ai); janet_panicf("could not get address info for bindhost: %s", gai_strerror(status)); } } /* Create socket */ JSock sock = JSOCKDEFAULT; void *addr = NULL; #ifndef JANET_WINDOWS if (is_unix) { sock = socket(AF_UNIX, socktype | JSOCKFLAGS, 0); if (!JSOCKVALID(sock)) { Janet v = janet_ev_lasterr(); janet_free(ai); janet_panicf("could not create socket: %V", v); } addr = (void *) ai; } else #endif { struct addrinfo *rp = NULL; for (rp = ai; rp != NULL; rp = rp->ai_next) { #ifdef JANET_WINDOWS sock = WSASocketW(rp->ai_family, rp->ai_socktype, rp->ai_protocol, NULL, 0, WSA_FLAG_OVERLAPPED); #else sock = socket(rp->ai_family, rp->ai_socktype | JSOCKFLAGS, rp->ai_protocol); #endif if (JSOCKVALID(sock)) { addr = rp->ai_addr; addrlen = (socklen_t) rp->ai_addrlen; break; } } if (NULL == addr) { Janet v = janet_ev_lasterr(); if (binding) freeaddrinfo(binding); freeaddrinfo(ai); janet_panicf("could not create socket: %V", v); } } /* Bind to bindhost and bindport if given */ if (binding) { struct addrinfo *rp = NULL; int did_bind = 0; for (rp = binding; rp != NULL; rp = rp->ai_next) { if (bind(sock, rp->ai_addr, (int) rp->ai_addrlen) == 0) { did_bind = 1; break; } } if (!did_bind) { Janet v = janet_ev_lasterr(); freeaddrinfo(binding); freeaddrinfo(ai); JSOCKCLOSE(sock); janet_panicf("could not bind outgoing address: %V", v); } else { freeaddrinfo(binding); } } /* Wrap socket in abstract type JanetStream */ uint32_t udp_flag = 0; if (socktype == SOCK_DGRAM) udp_flag = JANET_STREAM_UDPSERVER; JanetStream *stream = make_stream(sock, JANET_STREAM_READABLE | JANET_STREAM_WRITABLE | udp_flag); /* Connect to socket */ #ifdef JANET_WINDOWS int status = WSAConnect(sock, addr, addrlen, NULL, NULL, NULL, NULL); int err = WSAGetLastError(); freeaddrinfo(ai); /* Set up the socket for non-blocking IO after connecting on windows by default */ janet_net_socknoblock(sock); #else /* Set up the socket for non-blocking IO before connecting */ janet_net_socknoblock(sock); int status; do { status = connect(sock, addr, addrlen); } while (status == -1 && errno == EINTR); int err = errno; if (is_unix) { janet_free(ai); } else { freeaddrinfo(ai); } #endif if (status == 0) { /* Connect completed synchronously (common for unix domain sockets). * Return the stream directly without scheduling an async wait, * as edge-triggered kqueue may not signal EVFILT_WRITE if the socket * is already connected when registered. */ return janet_wrap_abstract(stream); } #ifdef JANET_WINDOWS if (status == SOCKET_ERROR) { if (err != WSAEWOULDBLOCK) { #else if (status == -1) { if (err != EINPROGRESS) { #endif JSOCKCLOSE(sock); Janet lasterr = janet_ev_lasterr(); janet_panicf("could not connect socket: %V", lasterr); } } net_sched_connect(stream); } JANET_CORE_FN(cfun_net_socket, "(net/socket &opt type address-family)", "Creates a new unbound socket. Type is an optional keyword, " "either a :stream (usually tcp), or :datagram (usually udp). The default is :stream. " "`address-family` should be one of :ipv4 or :ipv6.") { janet_arity(argc, 0, 2); int socktype = janet_get_sockettype(argv, argc, 0); /* Create socket */ JSock sfd = JSOCKDEFAULT; struct addrinfo *ai = NULL; struct addrinfo hints; memset(&hints, 0, sizeof(hints)); hints.ai_family = AF_UNSPEC; hints.ai_socktype = socktype; #ifdef AI_NUMERICSERV hints.ai_flags = AI_NUMERICSERV; /* Explicitly prevent name resolution */ #else hints.ai_flags = 0; #endif if (argc >= 2) { hints.ai_family = net_get_address_family(argv[1]); } int status = getaddrinfo(NULL, "0", &hints, &ai); if (status) { janet_panicf("could not get address info: %s", gai_strerror(status)); } struct addrinfo *rp = NULL; for (rp = ai; rp != NULL; rp = rp->ai_next) { #ifdef JANET_WINDOWS sfd = WSASocketW(rp->ai_family, rp->ai_socktype | JSOCKFLAGS, rp->ai_protocol, NULL, 0, WSA_FLAG_OVERLAPPED); #else sfd = socket(rp->ai_family, rp->ai_socktype | JSOCKFLAGS, rp->ai_protocol); #endif if (JSOCKVALID(sfd)) { break; } } freeaddrinfo(ai); if (!JSOCKVALID(sfd)) { Janet v = janet_ev_lasterr(); janet_panicf("could not create socket: %V", v); } /* Wrap socket in abstract type JanetStream */ uint32_t udp_flag = 0; if (socktype == SOCK_DGRAM) udp_flag = JANET_STREAM_UDPSERVER; JanetStream *stream = make_stream(sfd, JANET_STREAM_READABLE | JANET_STREAM_WRITABLE | udp_flag); /* Set up the socket for non-blocking IO */ janet_net_socknoblock(sfd); return janet_wrap_abstract(stream); } static const char *serverify_socket(JSock sfd, int reuse_addr, int reuse_port) { /* Set various socket options */ int enable = 1; if (reuse_addr) { if (setsockopt(sfd, SOL_SOCKET, SO_REUSEADDR, (char *) &enable, sizeof(int)) < 0) { return "setsockopt(SO_REUSEADDR) failed"; } } if (reuse_port) { #ifdef SO_REUSEPORT if (setsockopt(sfd, SOL_SOCKET, SO_REUSEPORT, &enable, sizeof(int)) < 0) { return "setsockopt(SO_REUSEPORT) failed"; } #else (void) reuse_port; #endif } janet_net_socknoblock(sfd); return NULL; } #ifdef JANET_WINDOWS #define JANET_SHUTDOWN_RW SD_BOTH #define JANET_SHUTDOWN_R SD_RECEIVE #define JANET_SHUTDOWN_W SD_SEND #else #define JANET_SHUTDOWN_RW SHUT_RDWR #define JANET_SHUTDOWN_R SHUT_RD #define JANET_SHUTDOWN_W SHUT_WR #endif JANET_CORE_FN(cfun_net_shutdown, "(net/shutdown stream &opt mode)", "Stop communication on this socket in a graceful manner, either in both directions or just " "reading/writing from the stream. The `mode` parameter controls which communication to stop on the socket. " "\n\n* `:wr` is the default and prevents both reading new data from the socket and writing new data to the socket.\n" "* `:r` disables reading new data from the socket.\n" "* `:w` disable writing data to the socket.\n\n" "Returns the original socket.") { janet_arity(argc, 1, 2); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_SOCKET); int shutdown_type = JANET_SHUTDOWN_RW; if (argc == 2) { const uint8_t *kw = janet_getkeyword(argv, 1); if (0 == janet_cstrcmp(kw, "rw")) { shutdown_type = JANET_SHUTDOWN_RW; } else if (0 == janet_cstrcmp(kw, "r")) { shutdown_type = JANET_SHUTDOWN_R; } else if (0 == janet_cstrcmp(kw, "w")) { shutdown_type = JANET_SHUTDOWN_W; } else { janet_panicf("unexpected keyword %v", argv[1]); } } int status; #ifdef JANET_WINDOWS status = shutdown((SOCKET) stream->handle, shutdown_type); #else do { status = shutdown(stream->handle, shutdown_type); } while (status == -1 && errno == EINTR); #endif if (status) { janet_panicf("could not shutdown socket: %V", janet_ev_lasterr()); } return argv[0]; } JANET_CORE_FN(cfun_net_listen, "(net/listen host port &opt type no-reuse)", "Creates a server. Returns a new stream that is neither readable nor " "writeable. Use net/accept or net/accept-loop be to handle connections and start the server. " "The type parameter specifies the type of network connection, either " "a :stream (usually tcp), or :datagram (usually udp). If not specified, the default is " ":stream. The host and port arguments are the same as in net/address. The last boolean parameter `no-reuse` will " "disable the use of `SO_REUSEADDR` and `SO_REUSEPORT` when creating a server on some operating systems.") { janet_sandbox_assert(JANET_SANDBOX_NET_LISTEN); janet_arity(argc, 2, 4); /* Get host, port, and handler*/ int socktype = janet_get_sockettype(argv, argc, 2); int is_unix = 0; socklen_t addrlen = 0; struct addrinfo *ai = janet_get_addrinfo(argv, 0, socktype, 1, &is_unix, &addrlen); int reuse = !(argc >= 4 && janet_truthy(argv[3])); JSock sfd = JSOCKDEFAULT; #ifndef JANET_WINDOWS if (is_unix) { sfd = socket(AF_UNIX, socktype | JSOCKFLAGS, 0); if (!JSOCKVALID(sfd)) { janet_free(ai); janet_panicf("could not create socket: %V", janet_ev_lasterr()); } const char *err = serverify_socket(sfd, reuse, 0); if (NULL != err || bind(sfd, (struct sockaddr *)ai, addrlen)) { JSOCKCLOSE(sfd); janet_free(ai); if (err) { janet_panic(err); } else { janet_panicf("could not bind socket: %V", janet_ev_lasterr()); } } janet_free(ai); } else #endif { /* Check all addrinfos in a loop for the first that we can bind to. */ struct addrinfo *rp = NULL; for (rp = ai; rp != NULL; rp = rp->ai_next) { #ifdef JANET_WINDOWS sfd = WSASocketW(rp->ai_family, rp->ai_socktype | JSOCKFLAGS, rp->ai_protocol, NULL, 0, WSA_FLAG_OVERLAPPED); #else sfd = socket(rp->ai_family, rp->ai_socktype | JSOCKFLAGS, rp->ai_protocol); #endif if (!JSOCKVALID(sfd)) continue; const char *err = serverify_socket(sfd, reuse, reuse); if (NULL != err) { JSOCKCLOSE(sfd); continue; } /* Bind */ if (bind(sfd, rp->ai_addr, (int) rp->ai_addrlen) == 0) break; JSOCKCLOSE(sfd); } freeaddrinfo(ai); if (NULL == rp) { janet_panic("could not bind to any sockets"); } } if (socktype == SOCK_DGRAM) { /* Datagram server (UDP) */ JanetStream *stream = make_stream(sfd, JANET_STREAM_UDPSERVER | JANET_STREAM_READABLE); return janet_wrap_abstract(stream); } else { /* Stream server (TCP) */ /* listen */ int status = listen(sfd, 1024); if (status) { JSOCKCLOSE(sfd); janet_panicf("could not listen on file descriptor: %V", janet_ev_lasterr()); } /* Put sfd on our loop */ JanetStream *stream = make_stream(sfd, JANET_STREAM_ACCEPTABLE); return janet_wrap_abstract(stream); } } /* Types of socket's we need to deal with - relevant type puns below. struct sockaddr *sa; // Common base structure struct sockaddr_storage *ss; // Size of largest socket address type struct sockaddr_in *sin; // IPv4 address + port struct sockaddr_in6 *sin6; // IPv6 address + port struct sockaddr_un *sun; // Unix Domain Socket Address */ /* Turn a socket address into a host, port pair. * For unix domain sockets, returned tuple will have only a single element, the path string. */ static Janet janet_so_getname(const void *sa_any) { const struct sockaddr *sa = sa_any; char buffer[SA_ADDRSTRLEN]; switch (sa->sa_family) { default: janet_panic("unknown address family"); case AF_INET: { const struct sockaddr_in *sai = sa_any; if (!inet_ntop(AF_INET, &(sai->sin_addr), buffer, sizeof(buffer))) { janet_panic("unable to decode ipv4 host address"); } Janet pair[2] = {janet_cstringv(buffer), janet_wrap_integer(ntohs(sai->sin_port))}; return janet_wrap_tuple(janet_tuple_n(pair, 2)); } #ifndef JANET_NO_IPV6 case AF_INET6: { const struct sockaddr_in6 *sai6 = sa_any; if (!inet_ntop(AF_INET6, &(sai6->sin6_addr), buffer, sizeof(buffer))) { janet_panic("unable to decode ipv4 host address"); } Janet pair[2] = {janet_cstringv(buffer), janet_wrap_integer(ntohs(sai6->sin6_port))}; return janet_wrap_tuple(janet_tuple_n(pair, 2)); } #endif #ifndef JANET_WINDOWS case AF_UNIX: { const struct sockaddr_un *sun = sa_any; Janet pathname; if (sun->sun_path[0] == '\0') { memcpy(buffer, sun->sun_path, sizeof(sun->sun_path)); buffer[0] = '@'; pathname = janet_cstringv(buffer); } else { pathname = janet_cstringv(sun->sun_path); } return janet_wrap_tuple(janet_tuple_n(&pathname, 1)); } #endif } } JANET_CORE_FN(cfun_net_getsockname, "(net/localname stream)", "Gets the local address and port in a tuple in that order.") { janet_fixarity(argc, 1); JanetStream *js = janet_getabstract(argv, 0, &janet_stream_type); if (js->flags & JANET_STREAM_CLOSED) janet_panic("stream closed"); struct sockaddr_storage ss; socklen_t slen = sizeof(ss); memset(&ss, 0, slen); if (getsockname((JSock)js->handle, (struct sockaddr *) &ss, &slen)) { janet_panicf("Failed to get localname on %v: %V", argv[0], janet_ev_lasterr()); } janet_assert(slen <= (socklen_t) sizeof(ss), "socket address truncated"); return janet_so_getname(&ss); } JANET_CORE_FN(cfun_net_getpeername, "(net/peername stream)", "Gets the remote peer's address and port in a tuple in that order.") { janet_fixarity(argc, 1); JanetStream *js = janet_getabstract(argv, 0, &janet_stream_type); if (js->flags & JANET_STREAM_CLOSED) janet_panic("stream closed"); struct sockaddr_storage ss; socklen_t slen = sizeof(ss); memset(&ss, 0, slen); if (getpeername((JSock)js->handle, (struct sockaddr *)&ss, &slen)) { janet_panicf("Failed to get peername on %v: %V", argv[0], janet_ev_lasterr()); } janet_assert(slen <= (socklen_t) sizeof(ss), "socket address truncated"); return janet_so_getname(&ss); } JANET_CORE_FN(cfun_net_address_unpack, "(net/address-unpack address)", "Given an address returned by net/address, return a host, port pair. Unix domain sockets " "will have only the path in the returned tuple.") { janet_fixarity(argc, 1); struct sockaddr *sa = janet_getabstract(argv, 0, &janet_address_type); return janet_so_getname(sa); } JANET_CORE_FN(cfun_stream_accept_loop, "(net/accept-loop stream handler)", "Shorthand for running a server stream that will continuously accept new connections. " "Blocks the current fiber until the stream is closed, and will return the stream.") { janet_fixarity(argc, 2); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_ACCEPTABLE | JANET_STREAM_SOCKET); JanetFunction *fun = janet_getfunction(argv, 1); if (fun->def->min_arity < 1) janet_panic("handler function must take at least 1 argument"); janet_sched_accept(stream, fun); } JANET_CORE_FN(cfun_stream_accept, "(net/accept stream &opt timeout)", "Get the next connection on a server stream. This would usually be called in a loop in a dedicated fiber. " "Takes an optional timeout in seconds, after which will raise an error. " "Returns a new duplex stream which represents a connection to the client.") { janet_arity(argc, 1, 2); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_ACCEPTABLE | JANET_STREAM_SOCKET); double to = janet_optnumber(argv, argc, 1, INFINITY); if (to != INFINITY) janet_addtimeout(to); janet_sched_accept(stream, NULL); } JANET_CORE_FN(cfun_stream_read, "(net/read stream nbytes &opt buf timeout)", "Read up to n bytes from a stream, suspending the current fiber until the bytes are available. " "`n` can also be the keyword `:all` to read into the buffer until end of stream. " "If less than n bytes are available (and more than 0), will push those bytes and return early. " "Takes an optional timeout in seconds, after which will raise an error. " "Returns a buffer with up to n more bytes in it, or raises an error if the read failed.") { janet_arity(argc, 2, 4); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_READABLE | JANET_STREAM_SOCKET); JanetBuffer *buffer = janet_optbuffer(argv, argc, 2, 10); double to = janet_optnumber(argv, argc, 3, INFINITY); if (janet_keyeq(argv[1], "all")) { if (to != INFINITY) janet_addtimeout(to); janet_ev_recvchunk(stream, buffer, INT32_MAX, MSG_NOSIGNAL); } else { int32_t n = janet_getnat(argv, 1); if (to != INFINITY) janet_addtimeout(to); janet_ev_recv(stream, buffer, n, MSG_NOSIGNAL); } } JANET_CORE_FN(cfun_stream_chunk, "(net/chunk stream nbytes &opt buf timeout)", "Same a net/read, but will wait for all n bytes to arrive rather than return early. " "Takes an optional timeout in seconds, after which will raise an error.") { janet_arity(argc, 2, 4); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_READABLE | JANET_STREAM_SOCKET); int32_t n = janet_getnat(argv, 1); JanetBuffer *buffer = janet_optbuffer(argv, argc, 2, 10); double to = janet_optnumber(argv, argc, 3, INFINITY); if (to != INFINITY) janet_addtimeout(to); janet_ev_recvchunk(stream, buffer, n, MSG_NOSIGNAL); } JANET_CORE_FN(cfun_stream_recv_from, "(net/recv-from stream nbytes buf &opt timeout)", "Receives data from a server stream and puts it into a buffer. Returns the socket-address the " "packet came from. Takes an optional timeout in seconds, after which will raise an error.") { janet_arity(argc, 3, 4); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_UDPSERVER | JANET_STREAM_SOCKET); int32_t n = janet_getnat(argv, 1); JanetBuffer *buffer = janet_getbuffer(argv, 2); double to = janet_optnumber(argv, argc, 3, INFINITY); if (to != INFINITY) janet_addtimeout(to); janet_ev_recvfrom(stream, buffer, n, MSG_NOSIGNAL); } JANET_CORE_FN(cfun_stream_write, "(net/write stream data &opt timeout)", "Write data to a stream, suspending the current fiber until the write " "completes. Takes an optional timeout in seconds, after which will raise an error. " "Returns nil, or raises an error if the write failed.") { janet_arity(argc, 2, 3); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_WRITABLE | JANET_STREAM_SOCKET); double to = janet_optnumber(argv, argc, 2, INFINITY); if (janet_checktype(argv[1], JANET_BUFFER)) { if (to != INFINITY) janet_addtimeout(to); janet_ev_send_buffer(stream, janet_getbuffer(argv, 1), MSG_NOSIGNAL); } else { JanetByteView bytes = janet_getbytes(argv, 1); if (to != INFINITY) janet_addtimeout(to); janet_ev_send_string(stream, bytes.bytes, MSG_NOSIGNAL); } } JANET_CORE_FN(cfun_stream_send_to, "(net/send-to stream dest data &opt timeout)", "Writes a datagram to a server stream. dest is a the destination address of the packet. " "Takes an optional timeout in seconds, after which will raise an error. " "Returns stream.") { janet_arity(argc, 3, 4); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_UDPSERVER | JANET_STREAM_SOCKET); void *dest = janet_getabstract(argv, 1, &janet_address_type); double to = janet_optnumber(argv, argc, 3, INFINITY); if (janet_checktype(argv[2], JANET_BUFFER)) { if (to != INFINITY) janet_addtimeout(to); janet_ev_sendto_buffer(stream, janet_getbuffer(argv, 2), dest, MSG_NOSIGNAL); } else { JanetByteView bytes = janet_getbytes(argv, 2); if (to != INFINITY) janet_addtimeout(to); janet_ev_sendto_string(stream, bytes.bytes, dest, MSG_NOSIGNAL); } } JANET_CORE_FN(cfun_stream_flush, "(net/flush stream)", "Make sure that a stream is not buffering any data. This temporarily disables Nagle's algorithm. " "Use this to make sure data is sent without delay. Returns stream.") { janet_fixarity(argc, 1); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_WRITABLE | JANET_STREAM_SOCKET); /* Toggle no delay flag */ int flag = 1; setsockopt((JSock) stream->handle, IPPROTO_TCP, TCP_NODELAY, (char *) &flag, sizeof(int)); flag = 0; setsockopt((JSock) stream->handle, IPPROTO_TCP, TCP_NODELAY, (char *) &flag, sizeof(int)); return argv[0]; } struct sockopt_type { const char *name; int level; int optname; enum JanetType type; }; /* List of supported socket options; The type JANET_POINTER is used * for options that require special handling depending on the type. */ static const struct sockopt_type sockopt_type_list[] = { { "so-broadcast", SOL_SOCKET, SO_BROADCAST, JANET_BOOLEAN }, { "so-reuseaddr", SOL_SOCKET, SO_REUSEADDR, JANET_BOOLEAN }, { "so-keepalive", SOL_SOCKET, SO_KEEPALIVE, JANET_BOOLEAN }, { "ip-multicast-ttl", IPPROTO_IP, IP_MULTICAST_TTL, JANET_NUMBER }, { "ip-add-membership", IPPROTO_IP, IP_ADD_MEMBERSHIP, JANET_POINTER }, { "ip-drop-membership", IPPROTO_IP, IP_DROP_MEMBERSHIP, JANET_POINTER }, #ifndef JANET_NO_IPV6 { "ipv6-join-group", IPPROTO_IPV6, IPV6_JOIN_GROUP, JANET_POINTER }, { "ipv6-leave-group", IPPROTO_IPV6, IPV6_LEAVE_GROUP, JANET_POINTER }, { "ipv6-multicast-hops", IPPROTO_IPV6, IPV6_MULTICAST_HOPS, JANET_NUMBER }, { "ipv6-unicast-hops", IPPROTO_IPV6, IPV6_UNICAST_HOPS, JANET_NUMBER }, #endif { NULL, 0, 0, JANET_POINTER } }; JANET_CORE_FN(cfun_net_setsockopt, "(net/setsockopt stream option value)", "set socket options.\n" "\n" "supported options and associated value types:\n" "- :so-broadcast boolean\n" "- :so-reuseaddr boolean\n" "- :so-keepalive boolean\n" "- :ip-multicast-ttl number\n" "- :ip-add-membership string\n" "- :ip-drop-membership string\n" "- :ipv6-join-group string\n" "- :ipv6-leave-group string\n" "- :ipv6-multicast-hops number\n" "- :ipv6-unicast-hops number\n" ) { janet_arity(argc, 3, 3); JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type); janet_stream_flags(stream, JANET_STREAM_SOCKET); JanetKeyword optstr = janet_getkeyword(argv, 1); const struct sockopt_type *st = sockopt_type_list; while (st->name) { if (janet_cstrcmp(optstr, st->name) == 0) { break; } st++; } if (st->name == NULL) { janet_panicf("unknown socket option %q", argv[1]); } union { unsigned char v_uchar; int v_int; struct ip_mreq v_mreq; #ifndef JANET_NO_IPV6 struct ipv6_mreq v_mreq6; #endif } val; void *optval = (void *)&val; socklen_t optlen = 0; if (st->type == JANET_BOOLEAN) { val.v_int = janet_getboolean(argv, 2); optlen = sizeof(val.v_int); } else if (st->type == JANET_NUMBER) { #ifdef JANET_BSD int v_int = janet_getinteger(argv, 2); if (st->optname == IP_MULTICAST_TTL) { val.v_uchar = v_int; optlen = sizeof(val.v_uchar); } else { val.v_int = v_int; optlen = sizeof(val.v_int); } #else val.v_int = janet_getinteger(argv, 2); optlen = sizeof(val.v_int); #endif } else if (st->optname == IP_ADD_MEMBERSHIP || st->optname == IP_DROP_MEMBERSHIP) { const char *addr = janet_getcstring(argv, 2); memset(&val.v_mreq, 0, sizeof val.v_mreq); val.v_mreq.imr_interface.s_addr = htonl(INADDR_ANY); inet_pton(AF_INET, addr, &val.v_mreq.imr_multiaddr.s_addr); optlen = sizeof(val.v_mreq); #ifndef JANET_NO_IPV6 } else if (st->optname == IPV6_JOIN_GROUP || st->optname == IPV6_LEAVE_GROUP) { const char *addr = janet_getcstring(argv, 2); memset(&val.v_mreq6, 0, sizeof val.v_mreq6); val.v_mreq6.ipv6mr_interface = 0; inet_pton(AF_INET6, addr, &val.v_mreq6.ipv6mr_multiaddr); optlen = sizeof(val.v_mreq6); #endif } else { janet_panicf("invalid socket option type"); } janet_assert(optlen != 0, "invalid socket option value"); int r = setsockopt((JSock) stream->handle, st->level, st->optname, optval, optlen); if (r == -1) { janet_panicf("setsockopt(%q): %s", argv[1], janet_strerror(errno)); } return janet_wrap_nil(); } static const JanetMethod net_stream_methods[] = { {"chunk", cfun_stream_chunk}, {"close", janet_cfun_stream_close}, {"read", cfun_stream_read}, {"write", cfun_stream_write}, {"flush", cfun_stream_flush}, {"accept", cfun_stream_accept}, {"accept-loop", cfun_stream_accept_loop}, {"send-to", cfun_stream_send_to}, {"recv-from", cfun_stream_recv_from}, {"evread", janet_cfun_stream_read}, {"evchunk", janet_cfun_stream_chunk}, {"evwrite", janet_cfun_stream_write}, {"shutdown", cfun_net_shutdown}, {"setsockopt", cfun_net_setsockopt}, {NULL, NULL} }; static JanetStream *make_stream(JSock handle, uint32_t flags) { return janet_stream((JanetHandle) handle, flags | JANET_STREAM_SOCKET, net_stream_methods); } void janet_lib_net(JanetTable *env) { JanetRegExt net_cfuns[] = { JANET_CORE_REG("net/address", cfun_net_sockaddr), JANET_CORE_REG("net/listen", cfun_net_listen), JANET_CORE_REG("net/socket", cfun_net_socket), JANET_CORE_REG("net/accept", cfun_stream_accept), JANET_CORE_REG("net/accept-loop", cfun_stream_accept_loop), JANET_CORE_REG("net/read", cfun_stream_read), JANET_CORE_REG("net/chunk", cfun_stream_chunk), JANET_CORE_REG("net/write", cfun_stream_write), JANET_CORE_REG("net/send-to", cfun_stream_send_to), JANET_CORE_REG("net/recv-from", cfun_stream_recv_from), JANET_CORE_REG("net/flush", cfun_stream_flush), JANET_CORE_REG("net/connect", cfun_net_connect), JANET_CORE_REG("net/shutdown", cfun_net_shutdown), JANET_CORE_REG("net/peername", cfun_net_getpeername), JANET_CORE_REG("net/localname", cfun_net_getsockname), JANET_CORE_REG("net/address-unpack", cfun_net_address_unpack), JANET_CORE_REG("net/setsockopt", cfun_net_setsockopt), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, net_cfuns); } void janet_net_init(void) { #ifdef JANET_WINDOWS WSADATA wsaData; janet_assert(!WSAStartup(MAKEWORD(2, 2), &wsaData), "could not start winsock"); #endif } void janet_net_deinit(void) { #ifdef JANET_WINDOWS WSACleanup(); #endif } #endif janet-1.41.2/src/core/os.c000066400000000000000000003137011514534607600152240ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose and contributors. * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "util.h" #include "gc.h" #endif #include #ifndef JANET_REDUCED_OS #include #include #include #include #include #include #include #include #include #include #ifdef JANET_BSD #include #endif #ifdef JANET_LINUX #include #endif #ifdef JANET_WINDOWS #include #include #include #include #include #define JANET_SPAWN_CHDIR #else #ifndef JANET_PLAN9 #include #endif #include #include #include #include #include #ifdef JANET_APPLE #include #define environ (*_NSGetEnviron()) #include int chroot(const char *dirname); #elif !defined(JANET_PLAN9) extern char **environ; #endif #ifdef JANET_THREADS #include #endif #endif /* Detect availability of posix_spawn_file_actions_addchdir_np. Since * this doesn't seem to follow any standard, just a common extension, we * must enumerate supported systems for availability. Define JANET_SPAWN_NO_CHDIR * to disable this. */ #ifndef JANET_SPAWN_NO_CHDIR #ifdef __GLIBC__ #define JANET_SPAWN_CHDIR #elif defined(JANET_APPLE) /* The posix_spawn_file_actions_addchdir_np function * has only been implemented since macOS 10.15 */ #if defined(MAC_OS_X_VERSION_10_15) && (MAC_OS_X_VERSION_MIN_REQUIRED >= MAC_OS_X_VERSION_10_15) #define JANET_SPAWN_CHDIR #else #define JANET_SPAWN_NO_CHDIR #endif #elif defined(__FreeBSD__) /* Not all BSDs work, for example openBSD doesn't seem to support this */ #define JANET_SPAWN_CHDIR #endif #endif /* Not POSIX, but all Unixes but Solaris have this function. */ #if defined(JANET_POSIX) && !defined(__sun) time_t timegm(struct tm *tm); #elif defined(JANET_WINDOWS) #define timegm _mkgmtime #endif /* Access to some global variables should be synchronized if not in single threaded mode, as * setenv/getenv are not thread safe. */ #ifdef JANET_THREADS # ifdef JANET_WINDOWS static CRITICAL_SECTION env_lock; static void janet_lock_environ(void) { EnterCriticalSection(&env_lock); } static void janet_unlock_environ(void) { LeaveCriticalSection(&env_lock); } # else static pthread_mutex_t env_lock = PTHREAD_MUTEX_INITIALIZER; static void janet_lock_environ(void) { pthread_mutex_lock(&env_lock); } static void janet_unlock_environ(void) { pthread_mutex_unlock(&env_lock); } # endif #else static void janet_lock_environ(void) { } static void janet_unlock_environ(void) { } #endif #endif /* JANET_REDCUED_OS */ /* Core OS functions */ /* Full OS functions */ #define janet_stringify1(x) #x #define janet_stringify(x) janet_stringify1(x) JANET_CORE_FN(os_which, "(os/which &opt test)", "Check the current operating system. If `test` is nil or unset, Returns one of:\n\n" "* :windows\n\n" "* :mingw\n\n" "* :cygwin\n\n" "* :macos\n\n" "* :web - Web assembly (emscripten)\n\n" "* :linux\n\n" "* :freebsd\n\n" "* :openbsd\n\n" "* :netbsd\n\n" "* :dragonfly\n\n" "* :bsd\n\n" "* :posix - A POSIX compatible system (default)\n\n" "May also return a custom keyword specified at build time. Is `test` is truthy, will check if the current operating system equals `test` and return true if they are the same, false otherwise.") { janet_arity(argc, 0, 1); if (argc == 1 && janet_truthy(argv[0])) { janet_getkeyword(argv, 0); /* Constrain to keywords */ return janet_wrap_boolean(janet_equals(argv[0], os_which(0, NULL))); } #if defined(JANET_OS_NAME) return janet_ckeywordv(janet_stringify(JANET_OS_NAME)); #elif defined(JANET_MINGW) return janet_ckeywordv("mingw"); #elif defined(JANET_CYGWIN) return janet_ckeywordv("cygwin"); #elif defined(JANET_WINDOWS) return janet_ckeywordv("windows"); #elif defined(JANET_APPLE) return janet_ckeywordv("macos"); #elif defined(__EMSCRIPTEN__) return janet_ckeywordv("web"); #elif defined(JANET_LINUX) return janet_ckeywordv("linux"); #elif defined(__FreeBSD__) return janet_ckeywordv("freebsd"); #elif defined(__NetBSD__) return janet_ckeywordv("netbsd"); #elif defined(__OpenBSD__) return janet_ckeywordv("openbsd"); #elif defined(__DragonFly__) return janet_ckeywordv("dragonfly"); #elif defined(JANET_BSD) return janet_ckeywordv("bsd"); #elif defined(JANET_ILLUMOS) return janet_ckeywordv("illumos"); #else return janet_ckeywordv("posix"); #endif } /* Detect the ISA we are compiled for */ JANET_CORE_FN(os_arch, "(os/arch)", "Check the ISA that janet was compiled for. Returns one of:\n\n" "* :x86\n\n" "* :x64\n\n" "* :arm\n\n" "* :aarch64\n\n" "* :riscv32\n\n" "* :riscv64\n\n" "* :sparc\n\n" "* :wasm\n\n" "* :s390\n\n" "* :s390x\n\n" "* :unknown\n") { janet_fixarity(argc, 0); (void) argv; /* Check 64-bit vs 32-bit */ #if defined(JANET_ARCH_NAME) return janet_ckeywordv(janet_stringify(JANET_ARCH_NAME)); #elif defined(__EMSCRIPTEN__) return janet_ckeywordv("wasm"); #elif (defined(__x86_64__) || defined(_M_X64)) return janet_ckeywordv("x64"); #elif defined(__i386) || defined(_M_IX86) return janet_ckeywordv("x86"); #elif defined(_M_ARM64) || defined(__aarch64__) return janet_ckeywordv("aarch64"); #elif defined(_M_ARM) || defined(__arm__) return janet_ckeywordv("arm"); #elif (defined(__riscv) && (__riscv_xlen == 64)) return janet_ckeywordv("riscv64"); #elif (defined(__riscv) && (__riscv_xlen == 32)) return janet_ckeywordv("riscv32"); #elif (defined(__sparc__)) return janet_ckeywordv("sparc"); #elif (defined(__ppc__)) return janet_ckeywordv("ppc"); #elif (defined(__ppc64__) || defined(_ARCH_PPC64) || defined(_M_PPC)) return janet_ckeywordv("ppc64"); #elif (defined(__s390x__)) return janet_ckeywordv("s390x"); #elif (defined(__s390__)) return janet_ckeywordv("s390"); #else return janet_ckeywordv("unknown"); #endif } /* Detect the compiler used to build the interpreter */ JANET_CORE_FN(os_compiler, "(os/compiler)", "Get the compiler used to compile the interpreter. Returns one of:\n\n" "* :gcc\n\n" "* :clang\n\n" "* :msvc\n\n" "* :kencc\n\n" "* :unknown\n\n") { janet_fixarity(argc, 0); (void) argv; #if defined(_MSC_VER) return janet_ckeywordv("msvc"); #elif defined(__clang__) return janet_ckeywordv("clang"); #elif defined(__GNUC__) return janet_ckeywordv("gcc"); #elif defined(JANET_PLAN9) return janet_ckeywordv("kencc"); #else return janet_ckeywordv("unknown"); #endif } #undef janet_stringify1 #undef janet_stringify JANET_CORE_FN(os_exit, "(os/exit &opt x force)", "Exit from janet with an exit code equal to x. If x is not an integer, " "the exit with status equal the hash of x. If `force` is truthy will exit immediately and " "skip cleanup code.") { janet_arity(argc, 0, 2); int status; if (argc == 0) { status = EXIT_SUCCESS; } else if (janet_checkint(argv[0])) { status = janet_unwrap_integer(argv[0]); } else { status = EXIT_FAILURE; } janet_deinit(); if (argc >= 2 && janet_truthy(argv[1])) { _Exit(status); } else { exit(status); } return janet_wrap_nil(); } #ifndef JANET_REDUCED_OS JANET_CORE_FN(os_cpu_count, "(os/cpu-count &opt dflt)", "Get an approximate number of CPUs available on for this process to use. If " "unable to get an approximation, will return a default value dflt.") { janet_arity(argc, 0, 1); (void) argv; /* Prevent unused argument warning */ #ifdef JANET_WINDOWS SYSTEM_INFO info; GetSystemInfo(&info); return janet_wrap_integer(info.dwNumberOfProcessors); #elif defined(JANET_LINUX) cpu_set_t cs; CPU_ZERO(&cs); sched_getaffinity(0, sizeof(cs), &cs); int count = CPU_COUNT(&cs); return janet_wrap_integer(count); #elif defined(JANET_BSD) && defined(HW_NCPUONLINE) const int name[2] = {CTL_HW, HW_NCPUONLINE}; int result = 0; size_t len = sizeof(int); if (-1 == sysctl(name, 2, &result, &len, NULL, 0)) { return argc > 0 ? argv[0] : janet_wrap_nil(); } return janet_wrap_integer(result); #elif defined(JANET_BSD) && defined(HW_NCPU) const int name[2] = {CTL_HW, HW_NCPU}; int result = 0; size_t len = sizeof(int); if (-1 == sysctl(name, 2, &result, &len, NULL, 0)) { return argc > 0 ? argv[0] : janet_wrap_nil(); } return janet_wrap_integer(result); #elif defined(JANET_ILLUMOS) long result = sysconf(_SC_NPROCESSORS_CONF); if (result < 0) { return argc > 0 ? argv[0] : janet_wrap_nil(); } return janet_wrap_integer(result); #elif defined(JANET_PLAN9) return janet_wrap_integer(atoi(getenv("NPROC"))); #else return argc > 0 ? argv[0] : janet_wrap_nil(); #endif } #ifndef JANET_NO_PROCESSES /* Get env for os_execute */ #ifdef JANET_WINDOWS typedef char *EnvBlock; #else typedef char **EnvBlock; #endif /* Get env for os_execute */ static EnvBlock os_execute_env(int32_t argc, const Janet *argv) { if (argc <= 2) return NULL; JanetDictView dict = janet_getdictionary(argv, 2); #ifdef JANET_WINDOWS JanetBuffer *temp = janet_buffer(10); for (int32_t i = 0; i < dict.cap; i++) { const JanetKV *kv = dict.kvs + i; if (!janet_checktype(kv->key, JANET_STRING)) continue; if (!janet_checktype(kv->value, JANET_STRING)) continue; const uint8_t *keys = janet_unwrap_string(kv->key); const uint8_t *vals = janet_unwrap_string(kv->value); janet_buffer_push_bytes(temp, keys, janet_string_length(keys)); janet_buffer_push_u8(temp, '='); janet_buffer_push_bytes(temp, vals, janet_string_length(vals)); janet_buffer_push_u8(temp, '\0'); } /* Windows environment blocks must be double-NULL terminated */ if (temp->count == 0) janet_buffer_push_u8(temp, '\0'); janet_buffer_push_u8(temp, '\0'); char *ret = janet_smalloc(temp->count); memcpy(ret, temp->data, temp->count); return ret; #else char **envp = janet_smalloc(sizeof(char *) * ((size_t)dict.len + 1)); int32_t j = 0; for (int32_t i = 0; i < dict.cap; i++) { const JanetKV *kv = dict.kvs + i; if (!janet_checktype(kv->key, JANET_STRING)) continue; if (!janet_checktype(kv->value, JANET_STRING)) continue; const uint8_t *keys = janet_unwrap_string(kv->key); const uint8_t *vals = janet_unwrap_string(kv->value); int32_t klen = janet_string_length(keys); int32_t vlen = janet_string_length(vals); /* Check keys has no embedded 0s or =s. */ int skip = 0; for (int32_t k = 0; k < klen; k++) { if (keys[k] == '\0' || keys[k] == '=') { skip = 1; break; } } if (skip) continue; char *envitem = janet_smalloc((size_t) klen + (size_t) vlen + 2); memcpy(envitem, keys, klen); envitem[klen] = '='; memcpy(envitem + klen + 1, vals, vlen); envitem[klen + vlen + 1] = 0; envp[j++] = envitem; } envp[j] = NULL; return envp; #endif } static void os_execute_cleanup(EnvBlock envp, const char **child_argv) { #ifdef JANET_WINDOWS (void) child_argv; if (NULL != envp) janet_sfree(envp); #else janet_sfree((void *)child_argv); if (NULL != envp) { char **envitem = envp; while (*envitem != NULL) { janet_sfree(*envitem); envitem++; } } janet_sfree(envp); #endif } #ifdef JANET_WINDOWS /* Windows processes created via CreateProcess get only one command line argument string, and * must parse this themselves. Each processes is free to do this however they like, but the * standard parsing method is CommandLineToArgvW. We need to properly escape arguments into * a single string of this format. Returns a buffer that can be cast into a c string. */ static JanetBuffer *os_exec_escape(JanetView args) { JanetBuffer *b = janet_buffer(0); for (int32_t i = 0; i < args.len; i++) { const char *arg = janet_getcstring(args.items, i); /* Push leading space if not first */ if (i) janet_buffer_push_u8(b, ' '); /* Find first special character */ const char *first_spec = arg; while (*first_spec) { switch (*first_spec) { case ' ': case '\t': case '\v': case '\n': case '"': goto found; case '\0': janet_panic("embedded 0 not allowed in command line string"); default: first_spec++; break; } } found: /* Check if needs escape */ if (*first_spec == '\0') { /* No escape needed */ janet_buffer_push_cstring(b, arg); } else { /* Escape */ janet_buffer_push_u8(b, '"'); for (const char *c = arg; ; c++) { unsigned numBackSlashes = 0; while (*c == '\\') { c++; numBackSlashes++; } if (*c == '"') { /* Escape all backslashes and double quote mark */ int32_t n = 2 * numBackSlashes + 1; janet_buffer_extra(b, n + 1); memset(b->data + b->count, '\\', n); b->count += n; janet_buffer_push_u8(b, '"'); } else if (*c) { /* Don't escape backslashes. */ int32_t n = numBackSlashes; janet_buffer_extra(b, n + 1); memset(b->data + b->count, '\\', n); b->count += n; janet_buffer_push_u8(b, *c); } else { /* we finished Escape all backslashes */ int32_t n = 2 * numBackSlashes; janet_buffer_extra(b, n + 1); memset(b->data + b->count, '\\', n); b->count += n; break; } } janet_buffer_push_u8(b, '"'); } } janet_buffer_push_u8(b, 0); return b; } #endif /* Process type for when running a subprocess and not immediately waiting */ static const JanetAbstractType ProcAT; #define JANET_PROC_CLOSED 1 #define JANET_PROC_WAITED 2 #define JANET_PROC_WAITING 4 #define JANET_PROC_ERROR_NONZERO 8 #define JANET_PROC_OWNS_STDIN 16 #define JANET_PROC_OWNS_STDOUT 32 #define JANET_PROC_OWNS_STDERR 64 #define JANET_PROC_ALLOW_ZOMBIE 128 typedef struct { int flags; #ifdef JANET_WINDOWS HANDLE pHandle; HANDLE tHandle; #else pid_t pid; #endif int return_code; #ifdef JANET_EV JanetStream *in; JanetStream *out; JanetStream *err; #else JanetFile *in; JanetFile *out; JanetFile *err; #endif } JanetProc; #ifdef JANET_EV #ifdef JANET_WINDOWS static JanetEVGenericMessage janet_proc_wait_subr(JanetEVGenericMessage args) { JanetProc *proc = (JanetProc *) args.argp; WaitForSingleObject(proc->pHandle, INFINITE); DWORD exitcode = 0; GetExitCodeProcess(proc->pHandle, &exitcode); args.tag = (int32_t) exitcode; return args; } #else /* windows check */ static int proc_get_status(JanetProc *proc) { /* Use POSIX shell semantics for interpreting signals */ int status = 0; pid_t result; do { result = waitpid(proc->pid, &status, 0); } while (result == -1 && errno == EINTR); if (WIFEXITED(status)) { status = WEXITSTATUS(status); } else if (WIFSTOPPED(status)) { status = WSTOPSIG(status) + 128; } else if (WIFSIGNALED(status)) { status = WTERMSIG(status) + 128; } else { /* Could possibly return -1 but for now, just panic */ janet_panicf("Undefined status code for process termination, %d.", status); } return status; } /* Function that is called in separate thread to wait on a pid */ static JanetEVGenericMessage janet_proc_wait_subr(JanetEVGenericMessage args) { JanetProc *proc = (JanetProc *) args.argp; args.tag = proc_get_status(proc); return args; } #endif /* End windows check */ /* Callback that is called in main thread when subroutine completes. */ static void janet_proc_wait_cb(JanetEVGenericMessage args) { JanetProc *proc = (JanetProc *) args.argp; if (NULL != proc) { int status = args.tag; proc->return_code = (int32_t) status; proc->flags |= JANET_PROC_WAITED; proc->flags &= ~JANET_PROC_WAITING; janet_gcunroot(janet_wrap_abstract(proc)); janet_gcunroot(janet_wrap_fiber(args.fiber)); uint32_t sched_id = (uint32_t) args.argi; if (janet_fiber_can_resume(args.fiber) && args.fiber->sched_id == sched_id) { if ((status != 0) && (proc->flags & JANET_PROC_ERROR_NONZERO)) { JanetString s = janet_formatc("command failed with non-zero exit code %d", status); janet_cancel(args.fiber, janet_wrap_string(s)); } else { janet_schedule(args.fiber, janet_wrap_integer(status)); } } } } #endif /* End ev check */ static int janet_proc_gc(void *p, size_t s) { (void) s; JanetProc *proc = (JanetProc *) p; #ifdef JANET_WINDOWS if (!(proc->flags & JANET_PROC_CLOSED)) { if (!(proc->flags & JANET_PROC_ALLOW_ZOMBIE)) { TerminateProcess(proc->pHandle, 1); } CloseHandle(proc->pHandle); CloseHandle(proc->tHandle); } #else if (!(proc->flags & (JANET_PROC_WAITED | JANET_PROC_ALLOW_ZOMBIE))) { /* Kill and wait to prevent zombies */ kill(proc->pid, SIGKILL); int status; if (!(proc->flags & JANET_PROC_WAITING)) { waitpid(proc->pid, &status, 0); } } #endif return 0; } static int janet_proc_mark(void *p, size_t s) { (void) s; JanetProc *proc = (JanetProc *)p; if (NULL != proc->in) janet_mark(janet_wrap_abstract(proc->in)); if (NULL != proc->out) janet_mark(janet_wrap_abstract(proc->out)); if (NULL != proc->err) janet_mark(janet_wrap_abstract(proc->err)); return 0; } #ifdef JANET_EV static JANET_NO_RETURN void #else static Janet #endif os_proc_wait_impl(JanetProc *proc) { if (proc->flags & (JANET_PROC_WAITED | JANET_PROC_WAITING)) { janet_panicf("cannot wait twice on a process"); } #ifdef JANET_EV /* Event loop implementation - threaded call */ proc->flags |= JANET_PROC_WAITING; JanetEVGenericMessage targs; memset(&targs, 0, sizeof(targs)); targs.argp = proc; targs.fiber = janet_root_fiber(); targs.argi = (uint32_t) targs.fiber->sched_id; janet_gcroot(janet_wrap_abstract(proc)); janet_gcroot(janet_wrap_fiber(targs.fiber)); janet_ev_threaded_call(janet_proc_wait_subr, targs, janet_proc_wait_cb); janet_await(); #else /* Non evented implementation */ proc->flags |= JANET_PROC_WAITED; int status = 0; #ifdef JANET_WINDOWS WaitForSingleObject(proc->pHandle, INFINITE); GetExitCodeProcess(proc->pHandle, &status); if (!(proc->flags & JANET_PROC_CLOSED)) { proc->flags |= JANET_PROC_CLOSED; CloseHandle(proc->pHandle); CloseHandle(proc->tHandle); } #else waitpid(proc->pid, &status, 0); #endif proc->return_code = (int32_t) status; return janet_wrap_integer(proc->return_code); #endif } JANET_CORE_FN(os_proc_wait, "(os/proc-wait proc)", "Suspend the current fiber until the subprocess `proc` completes. Once `proc` " "completes, return the exit code of `proc`. If called more than once on the same " "core/process value, will raise an error. When creating subprocesses using " "`os/spawn`, this function should be called on the returned value to avoid zombie " "processes.") { janet_fixarity(argc, 1); JanetProc *proc = janet_getabstract(argv, 0, &ProcAT); #ifdef JANET_EV os_proc_wait_impl(proc); #else return os_proc_wait_impl(proc); #endif } struct keyword_signal { const char *keyword; int signal; }; #ifndef JANET_WINDOWS static const struct keyword_signal signal_keywords[] = { #ifdef SIGKILL {"kill", SIGKILL}, #endif {"int", SIGINT}, {"abrt", SIGABRT}, {"fpe", SIGFPE}, {"ill", SIGILL}, {"segv", SIGSEGV}, #ifdef SIGTERM {"term", SIGTERM}, #endif #ifdef SIGALRM {"alrm", SIGALRM}, #endif #ifdef SIGHUP {"hup", SIGHUP}, #endif #ifdef SIGPIPE {"pipe", SIGPIPE}, #endif #ifdef SIGQUIT {"quit", SIGQUIT}, #endif #ifdef SIGUSR1 {"usr1", SIGUSR1}, #endif #ifdef SIGUSR2 {"usr2", SIGUSR2}, #endif #ifdef SIGCHLD {"chld", SIGCHLD}, #endif #ifdef SIGCONT {"cont", SIGCONT}, #endif #ifdef SIGSTOP {"stop", SIGSTOP}, #endif #ifdef SIGTSTP {"tstp", SIGTSTP}, #endif #ifdef SIGTTIN {"ttin", SIGTTIN}, #endif #ifdef SIGTTOU {"ttou", SIGTTOU}, #endif #ifdef SIGBUS {"bus", SIGBUS}, #endif #ifdef SIGPOLL {"poll", SIGPOLL}, #endif #ifdef SIGPROF {"prof", SIGPROF}, #endif #ifdef SIGSYS {"sys", SIGSYS}, #endif #ifdef SIGTRAP {"trap", SIGTRAP}, #endif #ifdef SIGURG {"urg", SIGURG}, #endif #ifdef SIGVTALRM {"vtlarm", SIGVTALRM}, #endif #ifdef SIGXCPU {"xcpu", SIGXCPU}, #endif #ifdef SIGXFSZ {"xfsz", SIGXFSZ}, #endif {NULL, 0}, }; static int get_signal_kw(const Janet *argv, int32_t n) { JanetKeyword signal_kw = janet_getkeyword(argv, n); const struct keyword_signal *ptr = signal_keywords; while (ptr->keyword) { if (!janet_cstrcmp(signal_kw, ptr->keyword)) { return ptr->signal; } ptr++; } janet_panicf("undefined signal %v", argv[n]); } #endif JANET_CORE_FN(os_proc_kill, "(os/proc-kill proc &opt wait signal)", "Kill the subprocess `proc` by sending SIGKILL to it on POSIX systems, or by closing " "the process handle on Windows. If `proc` has already completed, raise an error. If " "`wait` is truthy, will wait for `proc` to complete and return the exit code (this " "will raise an error if `proc` is being waited for). Otherwise, return `proc`. If " "`signal` is provided, send it instead of SIGKILL. Signal keywords are named after " "their C counterparts but in lowercase with the leading SIG stripped. `signal` is " "ignored on Windows.") { janet_arity(argc, 1, 3); JanetProc *proc = janet_getabstract(argv, 0, &ProcAT); if (proc->flags & JANET_PROC_WAITED) { janet_panicf("cannot kill process that has already finished"); } #ifdef JANET_WINDOWS if (proc->flags & JANET_PROC_CLOSED) { janet_panicf("cannot close process handle that is already closed"); } proc->flags |= JANET_PROC_CLOSED; TerminateProcess(proc->pHandle, 1); CloseHandle(proc->pHandle); CloseHandle(proc->tHandle); #else int signal = -1; if (argc == 3) { signal = get_signal_kw(argv, 2); } int status = kill(proc->pid, signal == -1 ? SIGKILL : signal); if (status) { janet_panic(janet_strerror(errno)); } #endif /* After killing process we wait on it. */ if (argc > 1 && janet_truthy(argv[1])) { #ifdef JANET_EV os_proc_wait_impl(proc); #else return os_proc_wait_impl(proc); #endif } else { return argv[0]; } } JANET_CORE_FN(os_proc_close, "(os/proc-close proc)", "Close pipes created for subprocess `proc` by `os/spawn` if they have not been " "closed. Then, if `proc` is not being waited for, wait. If this function waits, when " "`proc` completes, return the exit code of `proc`. Otherwise, return nil.") { janet_fixarity(argc, 1); JanetProc *proc = janet_getabstract(argv, 0, &ProcAT); #ifdef JANET_EV if (proc->flags & JANET_PROC_OWNS_STDIN) janet_stream_close(proc->in); if (proc->flags & JANET_PROC_OWNS_STDOUT) janet_stream_close(proc->out); if (proc->flags & JANET_PROC_OWNS_STDERR) janet_stream_close(proc->err); #else if (proc->flags & JANET_PROC_OWNS_STDIN) janet_file_close(proc->in); if (proc->flags & JANET_PROC_OWNS_STDOUT) janet_file_close(proc->out); if (proc->flags & JANET_PROC_OWNS_STDERR) janet_file_close(proc->err); #endif proc->flags &= ~(JANET_PROC_OWNS_STDIN | JANET_PROC_OWNS_STDOUT | JANET_PROC_OWNS_STDERR); if (proc->flags & (JANET_PROC_WAITED | JANET_PROC_WAITING)) { return janet_wrap_nil(); } #ifdef JANET_EV os_proc_wait_impl(proc); #else return os_proc_wait_impl(proc); #endif } JANET_CORE_FN(os_proc_getpid, "(os/getpid)", "Get the process ID of the current process.") { janet_sandbox_assert(JANET_SANDBOX_SUBPROCESS); janet_fixarity(argc, 0); (void) argv; #ifdef JANET_WINDOWS return janet_wrap_number((double) _getpid()); #else return janet_wrap_number((double) getpid()); #endif } static void swap_handles(JanetHandle *handles) { JanetHandle temp = handles[0]; handles[0] = handles[1]; handles[1] = temp; } static void close_handle(JanetHandle handle) { #ifdef JANET_WINDOWS CloseHandle(handle); #else close(handle); #endif } #ifdef JANET_EV #ifndef JANET_WINDOWS static void janet_signal_callback(JanetEVGenericMessage msg) { int sig = msg.tag; if (msg.argi) janet_interpreter_interrupt_handled(NULL); Janet handlerv = janet_table_get(&janet_vm.signal_handlers, janet_wrap_integer(sig)); if (!janet_checktype(handlerv, JANET_FUNCTION)) { /* Let another thread/process try to handle this */ sigset_t set; sigemptyset(&set); sigaddset(&set, sig); #ifdef JANET_THREADS pthread_sigmask(SIG_BLOCK, &set, NULL); #else sigprocmask(SIG_BLOCK, &set, NULL); #endif raise(sig); return; } JanetFunction *handler = janet_unwrap_function(handlerv); JanetFiber *fiber = janet_fiber(handler, 64, 0, NULL); janet_schedule_soon(fiber, janet_wrap_nil(), JANET_SIGNAL_OK); } static void janet_signal_trampoline_no_interrupt(int sig) { /* Do not interact with global janet state here except for janet_ev_post_event, unsafe! */ JanetEVGenericMessage msg; memset(&msg, 0, sizeof(msg)); msg.tag = sig; janet_ev_post_event(&janet_vm, janet_signal_callback, msg); } static void janet_signal_trampoline(int sig) { /* Do not interact with global janet state here except for janet_ev_post_event, unsafe! */ JanetEVGenericMessage msg; memset(&msg, 0, sizeof(msg)); msg.tag = sig; msg.argi = 1; janet_interpreter_interrupt(NULL); janet_ev_post_event(&janet_vm, janet_signal_callback, msg); } #endif JANET_CORE_FN(os_sigaction, "(os/sigaction which &opt handler interrupt-interpreter)", "Add a signal handler for a given action. Use nil for the `handler` argument to remove a signal handler. " "All signal handlers are the same as supported by `os/proc-kill`.") { janet_sandbox_assert(JANET_SANDBOX_SIGNAL); janet_arity(argc, 1, 3); #ifdef JANET_WINDOWS (void) argv; janet_panic("unsupported on this platform"); #else /* TODO - per thread signal masks */ int rc; int sig = get_signal_kw(argv, 0); JanetFunction *handler = janet_optfunction(argv, argc, 1, NULL); int can_interrupt = janet_optboolean(argv, argc, 2, 0); Janet oldhandler = janet_table_get(&janet_vm.signal_handlers, janet_wrap_integer(sig)); if (!janet_checktype(oldhandler, JANET_NIL)) { janet_gcunroot(oldhandler); } if (NULL != handler) { Janet handlerv = janet_wrap_function(handler); janet_gcroot(handlerv); janet_table_put(&janet_vm.signal_handlers, janet_wrap_integer(sig), handlerv); } else { janet_table_put(&janet_vm.signal_handlers, janet_wrap_integer(sig), janet_wrap_nil()); } struct sigaction action; sigset_t mask; sigaddset(&mask, sig); memset(&action, 0, sizeof(action)); action.sa_flags |= SA_RESTART; if (can_interrupt) { #ifdef JANET_NO_INTERPRETER_INTERRUPT janet_panic("interpreter interrupt not enabled"); #else action.sa_handler = janet_signal_trampoline; #endif } else { action.sa_handler = janet_signal_trampoline_no_interrupt; } action.sa_mask = mask; RETRY_EINTR(rc, sigaction(sig, &action, NULL)); sigset_t set; sigemptyset(&set); sigaddset(&set, sig); #ifdef JANET_THREADS pthread_sigmask(SIG_UNBLOCK, &set, NULL); #else sigprocmask(SIG_UNBLOCK, &set, NULL); #endif return janet_wrap_nil(); #endif } #endif /* Create piped file for os/execute and os/spawn. Need to be careful that we mark the error flag if we can't create pipe and don't leak handles. *handle will be cleaned up by the calling function. If everything goes well, *handle is owned by the calling function, (if it is set) and the returned handle owns the other end of the pipe, which will be closed on GC or fclose. */ static JanetHandle make_pipes(JanetHandle *handle, int reverse, int *errflag) { JanetHandle handles[2]; #ifdef JANET_EV /* non-blocking pipes */ if (janet_make_pipe(handles, reverse ? 2 : 1)) goto error; if (reverse) swap_handles(handles); #ifdef JANET_WINDOWS if (!SetHandleInformation(handles[0], HANDLE_FLAG_INHERIT, 0)) goto error; #endif *handle = handles[1]; return handles[0]; #else /* Normal blocking pipes */ #ifdef JANET_WINDOWS SECURITY_ATTRIBUTES saAttr; memset(&saAttr, 0, sizeof(saAttr)); saAttr.nLength = sizeof(saAttr); saAttr.bInheritHandle = TRUE; if (!CreatePipe(handles, handles + 1, &saAttr, 0)) goto error; if (reverse) swap_handles(handles); /* Don't inherit the side of the pipe owned by this process */ if (!SetHandleInformation(handles[0], HANDLE_FLAG_INHERIT, 0)) goto error; *handle = handles[1]; return handles[0]; #else if (pipe(handles)) goto error; if (reverse) swap_handles(handles); *handle = handles[1]; return handles[0]; #endif #endif error: *errflag = 1; return JANET_HANDLE_NONE; } static const JanetMethod proc_methods[] = { {"wait", os_proc_wait}, {"kill", os_proc_kill}, {"close", os_proc_close}, /* dud methods for janet_proc_next */ {"in", NULL}, {"out", NULL}, {"err", NULL}, {NULL, NULL} }; static int janet_proc_get(void *p, Janet key, Janet *out) { JanetProc *proc = (JanetProc *)p; if (janet_keyeq(key, "in")) { *out = (NULL == proc->in) ? janet_wrap_nil() : janet_wrap_abstract(proc->in); return 1; } if (janet_keyeq(key, "out")) { *out = (NULL == proc->out) ? janet_wrap_nil() : janet_wrap_abstract(proc->out); return 1; } if (janet_keyeq(key, "err")) { *out = (NULL == proc->err) ? janet_wrap_nil() : janet_wrap_abstract(proc->err); return 1; } #ifndef JANET_WINDOWS if (janet_keyeq(key, "pid")) { *out = janet_wrap_number(proc->pid); return 1; } #endif if ((-1 != proc->return_code) && janet_keyeq(key, "return-code")) { *out = janet_wrap_integer(proc->return_code); return 1; } if (!janet_checktype(key, JANET_KEYWORD)) return 0; return janet_getmethod(janet_unwrap_keyword(key), proc_methods, out); } static Janet janet_proc_next(void *p, Janet key) { (void) p; return janet_nextmethod(proc_methods, key); } static const JanetAbstractType ProcAT = { "core/process", janet_proc_gc, janet_proc_mark, janet_proc_get, NULL, /* put */ NULL, /* marshal */ NULL, /* unmarshal */ NULL, /* tostring */ NULL, /* compare */ NULL, /* hash */ janet_proc_next, JANET_ATEND_NEXT }; static JanetHandle janet_getjstream(Janet *argv, int32_t n, void **orig) { #ifdef JANET_EV JanetStream *stream = janet_checkabstract(argv[n], &janet_stream_type); if (stream != NULL) { if (stream->flags & JANET_STREAM_CLOSED) janet_panic("stream is closed"); *orig = stream; return stream->handle; } #endif JanetFile *f = janet_checkabstract(argv[n], &janet_file_type); if (f != NULL) { if (f->flags & JANET_FILE_CLOSED) { janet_panic("file is closed"); } *orig = f; #ifdef JANET_WINDOWS return (HANDLE) _get_osfhandle(_fileno(f->file)); #else return fileno(f->file); #endif } janet_panicf("expected file|stream, got %v", argv[n]); } #ifdef JANET_EV static JanetStream *get_stdio_for_handle(JanetHandle handle, void *orig, int iswrite) { if (orig == NULL) { return janet_stream(handle, iswrite ? JANET_STREAM_WRITABLE : JANET_STREAM_READABLE, NULL); } else if (janet_abstract_type(orig) == &janet_file_type) { JanetFile *jf = (JanetFile *)orig; uint32_t flags = 0; if (jf->flags & JANET_FILE_WRITE) { flags |= JANET_STREAM_WRITABLE; } if (jf->flags & JANET_FILE_READ) { flags |= JANET_STREAM_READABLE; } /* duplicate handle when converting file to stream */ #ifdef JANET_WINDOWS HANDLE prochandle = GetCurrentProcess(); HANDLE newHandle = INVALID_HANDLE_VALUE; if (!DuplicateHandle(prochandle, handle, prochandle, &newHandle, 0, FALSE, DUPLICATE_SAME_ACCESS)) { return NULL; } #else int newHandle = dup(handle); if (newHandle < 0) { return NULL; } #endif return janet_stream(newHandle, flags, NULL); } else { return orig; } } #else static JanetFile *get_stdio_for_handle(JanetHandle handle, void *orig, int iswrite) { if (NULL != orig) return (JanetFile *) orig; #ifdef JANET_WINDOWS int fd = _open_osfhandle((intptr_t) handle, iswrite ? _O_WRONLY : _O_RDONLY); if (-1 == fd) return NULL; FILE *f = _fdopen(fd, iswrite ? "w" : "r"); if (NULL == f) { _close(fd); return NULL; } #else FILE *f = fdopen(handle, iswrite ? "w" : "r"); if (NULL == f) return NULL; #endif return janet_makejfile(f, iswrite ? JANET_FILE_WRITE : JANET_FILE_READ); } #endif typedef enum { JANET_EXECUTE_EXECUTE, JANET_EXECUTE_SPAWN, JANET_EXECUTE_EXEC } JanetExecuteMode; static Janet os_execute_impl(int32_t argc, Janet *argv, JanetExecuteMode mode) { janet_sandbox_assert(JANET_SANDBOX_SUBPROCESS); janet_arity(argc, 1, 3); /* Get flags */ int is_spawn = mode == JANET_EXECUTE_SPAWN; uint64_t flags = 0; if (argc > 1) { flags = janet_getflags(argv, 1, "epxd"); } /* Get environment */ int use_environ = !janet_flag_at(flags, 0); EnvBlock envp = os_execute_env(argc, argv); /* Get arguments */ JanetView exargs = janet_getindexed(argv, 0); if (exargs.len < 1) { janet_panic("expected at least 1 command line argument"); } /* Optional stdio redirections */ JanetAbstract orig_in = NULL, orig_out = NULL, orig_err = NULL; JanetHandle new_in = JANET_HANDLE_NONE, new_out = JANET_HANDLE_NONE, new_err = JANET_HANDLE_NONE; JanetHandle pipe_in = JANET_HANDLE_NONE, pipe_out = JANET_HANDLE_NONE, pipe_err = JANET_HANDLE_NONE; int stderr_is_stdout = 0; int pipe_errflag = 0; /* Track errors setting up pipes */ int pipe_owner_flags = (is_spawn && (flags & 0x8)) ? JANET_PROC_ALLOW_ZOMBIE : 0; /* Get optional redirections */ if (argc > 2 && (mode != JANET_EXECUTE_EXEC)) { JanetDictView tab = janet_getdictionary(argv, 2); Janet maybe_stdin = janet_dictionary_get(tab.kvs, tab.cap, janet_ckeywordv("in")); Janet maybe_stdout = janet_dictionary_get(tab.kvs, tab.cap, janet_ckeywordv("out")); Janet maybe_stderr = janet_dictionary_get(tab.kvs, tab.cap, janet_ckeywordv("err")); if (is_spawn && janet_keyeq(maybe_stdin, "pipe")) { new_in = make_pipes(&pipe_in, 1, &pipe_errflag); pipe_owner_flags |= JANET_PROC_OWNS_STDIN; } else if (!janet_checktype(maybe_stdin, JANET_NIL)) { new_in = janet_getjstream(&maybe_stdin, 0, &orig_in); } if (is_spawn && janet_keyeq(maybe_stdout, "pipe")) { new_out = make_pipes(&pipe_out, 0, &pipe_errflag); pipe_owner_flags |= JANET_PROC_OWNS_STDOUT; } else if (!janet_checktype(maybe_stdout, JANET_NIL)) { new_out = janet_getjstream(&maybe_stdout, 0, &orig_out); } if (is_spawn && janet_keyeq(maybe_stderr, "pipe")) { new_err = make_pipes(&pipe_err, 0, &pipe_errflag); pipe_owner_flags |= JANET_PROC_OWNS_STDERR; } else if (janet_keyeq(maybe_stderr, "out")) { stderr_is_stdout = 1; } else if (!janet_checktype(maybe_stderr, JANET_NIL)) { new_err = janet_getjstream(&maybe_stderr, 0, &orig_err); } } /* Optional working directory. Available for both os/execute and os/spawn. */ const char *chdir_path = NULL; if (argc > 2) { JanetDictView tab = janet_getdictionary(argv, 2); Janet workdir = janet_dictionary_get(tab.kvs, tab.cap, janet_ckeywordv("cd")); if (janet_checktype(workdir, JANET_STRING)) { chdir_path = (const char *) janet_unwrap_string(workdir); #ifndef JANET_SPAWN_CHDIR janet_panicf(":cd argument not supported on this system - %s", chdir_path); #endif } else if (!janet_checktype(workdir, JANET_NIL)) { janet_panicf("expected string for :cd argumnet, got %v", workdir); } } /* Clean up if any of the pipes have any issues */ if (pipe_errflag) { if (pipe_in != JANET_HANDLE_NONE) close_handle(pipe_in); if (pipe_out != JANET_HANDLE_NONE) close_handle(pipe_out); if (pipe_err != JANET_HANDLE_NONE) close_handle(pipe_err); janet_panic("failed to create pipes"); } #ifdef JANET_WINDOWS HANDLE pHandle, tHandle; SECURITY_ATTRIBUTES saAttr; PROCESS_INFORMATION processInfo; STARTUPINFO startupInfo; LPCSTR lpCurrentDirectory = NULL; memset(&saAttr, 0, sizeof(saAttr)); memset(&processInfo, 0, sizeof(processInfo)); memset(&startupInfo, 0, sizeof(startupInfo)); startupInfo.cb = sizeof(startupInfo); startupInfo.dwFlags |= STARTF_USESTDHANDLES; saAttr.nLength = sizeof(saAttr); JanetBuffer *buf = os_exec_escape(exargs); if (buf->count > 8191) { if (pipe_in != JANET_HANDLE_NONE) CloseHandle(pipe_in); if (pipe_out != JANET_HANDLE_NONE) CloseHandle(pipe_out); if (pipe_err != JANET_HANDLE_NONE) CloseHandle(pipe_err); janet_panic("command line string too long (max 8191 characters)"); } const char *path = (const char *) janet_unwrap_string(exargs.items[0]); if (chdir_path != NULL) { lpCurrentDirectory = chdir_path; } /* Do IO redirection */ if (pipe_in != JANET_HANDLE_NONE) { startupInfo.hStdInput = pipe_in; } else if (new_in != JANET_HANDLE_NONE) { startupInfo.hStdInput = new_in; } else { startupInfo.hStdInput = (HANDLE) _get_osfhandle(_fileno(stdin)); } if (pipe_out != JANET_HANDLE_NONE) { startupInfo.hStdOutput = pipe_out; } else if (new_out != JANET_HANDLE_NONE) { startupInfo.hStdOutput = new_out; } else { startupInfo.hStdOutput = (HANDLE) _get_osfhandle(_fileno(stdout)); } if (pipe_err != JANET_HANDLE_NONE) { startupInfo.hStdError = pipe_err; } else if (new_err != NULL) { startupInfo.hStdError = new_err; } else if (stderr_is_stdout) { startupInfo.hStdError = startupInfo.hStdOutput; } else { startupInfo.hStdError = (HANDLE) _get_osfhandle(_fileno(stderr)); } int cp_failed = 0; DWORD cp_error_code = 0; if (!CreateProcess(janet_flag_at(flags, 1) ? NULL : path, (char *) buf->data, /* Single CLI argument */ &saAttr, /* no proc inheritance */ &saAttr, /* no thread inheritance */ TRUE, /* handle inheritance */ 0, /* flags */ use_environ ? NULL : envp, /* pass in environment */ lpCurrentDirectory, &startupInfo, &processInfo)) { cp_failed = 1; cp_error_code = GetLastError(); } if (pipe_in != JANET_HANDLE_NONE) CloseHandle(pipe_in); if (pipe_out != JANET_HANDLE_NONE) CloseHandle(pipe_out); if (pipe_err != JANET_HANDLE_NONE) CloseHandle(pipe_err); os_execute_cleanup(envp, NULL); if (cp_failed) { char msgbuf[256]; msgbuf[0] = '\0'; FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, NULL, cp_error_code, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), msgbuf, sizeof(msgbuf), NULL); if (!*msgbuf) snprintf(msgbuf, sizeof(msgbuf), "%" PRIu32, cp_error_code); char *c = msgbuf; while (*c) { if (*c == '\n' || *c == '\r') { *c = '\0'; break; } c++; } janet_panicf("failed to create process: %s", janet_cstringv(msgbuf)); } pHandle = processInfo.hProcess; tHandle = processInfo.hThread; #else /* Result */ int status = 0; const char **child_argv = janet_smalloc(sizeof(char *) * ((size_t) exargs.len + 1)); for (int32_t i = 0; i < exargs.len; i++) child_argv[i] = janet_getcstring(exargs.items, i); child_argv[exargs.len] = NULL; /* Coerce to form that works for spawn. I'm fairly confident no implementation * of posix_spawn would modify the argv array passed in. */ char *const *cargv = (char *const *)child_argv; if (use_environ) { janet_lock_environ(); } /* exec mode */ if (mode == JANET_EXECUTE_EXEC) { int status; #ifdef JANET_PLAN9 status = exec(cargv[0], cargv); #else if (!use_environ) { environ = envp; } do { if (janet_flag_at(flags, 1)) { status = execvp(cargv[0], cargv); } else { status = execv(cargv[0], cargv); } } while (status == -1 && errno == EINTR); #endif janet_panicf("%p: %s", cargv[0], janet_strerror(errno ? errno : ENOENT)); } #ifndef JANET_NO_SPAWN /* Use posix_spawn to spawn new process */ /* Posix spawn setup */ posix_spawn_file_actions_t actions; posix_spawn_file_actions_init(&actions); #ifdef JANET_SPAWN_CHDIR if (chdir_path != NULL) { #ifdef JANET_SPAWN_CHDIR_NO_NP posix_spawn_file_actions_addchdir(&actions, chdir_path); #else posix_spawn_file_actions_addchdir_np(&actions, chdir_path); #endif } #endif if (pipe_in != JANET_HANDLE_NONE) { posix_spawn_file_actions_adddup2(&actions, pipe_in, 0); posix_spawn_file_actions_addclose(&actions, pipe_in); } else if (new_in != JANET_HANDLE_NONE && new_in != 0) { posix_spawn_file_actions_adddup2(&actions, new_in, 0); if (new_in != new_out && new_in != new_err) posix_spawn_file_actions_addclose(&actions, new_in); } if (pipe_out != JANET_HANDLE_NONE) { posix_spawn_file_actions_adddup2(&actions, pipe_out, 1); posix_spawn_file_actions_addclose(&actions, pipe_out); } else if (new_out != JANET_HANDLE_NONE && new_out != 1) { posix_spawn_file_actions_adddup2(&actions, new_out, 1); if (new_out != new_err) posix_spawn_file_actions_addclose(&actions, new_out); } if (pipe_err != JANET_HANDLE_NONE) { posix_spawn_file_actions_adddup2(&actions, pipe_err, 2); posix_spawn_file_actions_addclose(&actions, pipe_err); } else if (new_err != JANET_HANDLE_NONE && new_err != 2) { posix_spawn_file_actions_adddup2(&actions, new_err, 2); posix_spawn_file_actions_addclose(&actions, new_err); } else if (stderr_is_stdout) { posix_spawn_file_actions_adddup2(&actions, 1, 2); } pid_t pid; if (janet_flag_at(flags, 1)) { status = posix_spawnp(&pid, child_argv[0], &actions, NULL, cargv, use_environ ? environ : envp); } else { status = posix_spawn(&pid, child_argv[0], &actions, NULL, cargv, use_environ ? environ : envp); } posix_spawn_file_actions_destroy(&actions); if (pipe_in != JANET_HANDLE_NONE) close(pipe_in); if (pipe_out != JANET_HANDLE_NONE) close(pipe_out); if (pipe_err != JANET_HANDLE_NONE) close(pipe_err); if (use_environ) { janet_unlock_environ(); } os_execute_cleanup(envp, child_argv); if (status) { /* correct for macos bug where errno is not set */ janet_panicf("%p: %s", argv[0], janet_strerror(errno ? errno : ENOENT)); } #endif #endif #ifndef JANET_NO_SPAWN JanetProc *proc = janet_abstract(&ProcAT, sizeof(JanetProc)); proc->return_code = -1; #ifdef JANET_WINDOWS proc->pHandle = pHandle; proc->tHandle = tHandle; #else proc->pid = pid; #endif proc->in = NULL; proc->out = NULL; proc->err = NULL; proc->flags = pipe_owner_flags; if (janet_flag_at(flags, 2)) { proc->flags |= JANET_PROC_ERROR_NONZERO; } if (is_spawn) { /* Only set up pointers to stdin, stdout, and stderr if os/spawn. */ if (new_in != JANET_HANDLE_NONE) { proc->in = get_stdio_for_handle(new_in, orig_in, 1); if (NULL == proc->in) janet_panic("failed to construct proc"); } if (new_out != JANET_HANDLE_NONE) { proc->out = get_stdio_for_handle(new_out, orig_out, 0); if (NULL == proc->out) janet_panic("failed to construct proc"); } if (new_err != JANET_HANDLE_NONE) { proc->err = get_stdio_for_handle(new_err, orig_err, 0); if (NULL == proc->err) janet_panic("failed to construct proc"); } return janet_wrap_abstract(proc); } else { #ifdef JANET_EV os_proc_wait_impl(proc); #else return os_proc_wait_impl(proc); #endif } #endif } JANET_CORE_FN(os_execute, "(os/execute args &opt flags env)", "Execute a program on the system and return the exit code. `args` is an array/tuple " "of strings. The first string is the name of the program and the remainder are " "arguments passed to the program. `flags` is a keyword made from the following " "characters that modifies how the program executes:\n" "* :e - enables passing an environment to the program. Without 'e', the " "current environment is inherited.\n" "* :p - allows searching the current PATH for the program to execute. " "Without this flag, the first element of `args` must be an absolute path.\n" "* :x - raises error if exit code is non-zero.\n" "* :d - prevents the garbage collector terminating the program (if still running) " "and calling the equivalent of `os/proc-wait` (allows zombie processes).\n" "`env` is a table/struct mapping environment variables to values. It can also " "contain the keys :in, :out, and :err, which allow redirecting stdio in the " "subprocess. :in, :out, and :err should be core/file or core/stream values. " "If core/stream values are used, the caller is responsible for ensuring pipes do not " "cause the program to block and deadlock.") { return os_execute_impl(argc, argv, JANET_EXECUTE_EXECUTE); } JANET_CORE_FN(os_spawn, "(os/spawn args &opt flags env)", "Execute a program on the system and return a core/process value representing the " "spawned subprocess. Takes the same arguments as `os/execute` but does not wait for " "the subprocess to complete. Unlike `os/execute`, the value `:pipe` can be used for " ":in, :out and :err keys in `env`. If used, the returned core/process will have a " "writable stream in the :in field and readable streams in the :out and :err fields. " "On non-Windows systems, the subprocess PID will be in the :pid field. The caller is " "responsible for waiting on the process (e.g. by calling `os/proc-wait` on the " "returned core/process value) to avoid creating zombie process. After the subprocess " "completes, the exit value is in the :return-code field. If `flags` includes 'x', a " "non-zero exit code will cause a waiting fiber to raise an error. The use of " "`:pipe` may fail if there are too many active file descriptors. The caller is " "responsible for closing pipes created by `:pipe` (either individually or using " "`os/proc-close`). Similar to `os/execute`, the caller is responsible for ensuring " "pipes do not cause the program to block and deadlock. As a special case, the stream passed to `:err` " "can be the keyword `:out` to redirect stderr to stdout in the subprocess.") { return os_execute_impl(argc, argv, JANET_EXECUTE_SPAWN); } JANET_CORE_FN(os_posix_exec, "(os/posix-exec args &opt flags env)", "Use the execvpe or execve system calls to replace the current process with an interface similar to os/execute. " "However, instead of creating a subprocess, the current process is replaced. Is not supported on Windows, and " "does not allow redirection of stdio.") { #ifdef JANET_WINDOWS (void) argc; (void) argv; janet_panic("not supported on Windows"); #else return os_execute_impl(argc, argv, JANET_EXECUTE_EXEC); #endif } JANET_CORE_FN(os_posix_fork, "(os/posix-fork)", "Make a `fork` system call and create a new process. Return nil if in the new process, otherwise a core/process object (as returned by os/spawn). " "Not supported on all systems (POSIX and Plan 9 only).") { janet_sandbox_assert(JANET_SANDBOX_SUBPROCESS); janet_fixarity(argc, 0); (void) argv; #ifdef JANET_WINDOWS janet_panic("not supported on Windows"); #else pid_t result; #ifdef JANET_PLAN9 result = fork(); #else do { result = fork(); } while (result == -1 && errno == EINTR); #endif if (result == -1) { janet_panic(janet_strerror(errno)); } if (result) { JanetProc *proc = janet_abstract(&ProcAT, sizeof(JanetProc)); memset(proc, 0, sizeof(JanetProc)); proc->pid = result; proc->flags = JANET_PROC_ALLOW_ZOMBIE; return janet_wrap_abstract(proc); } return janet_wrap_nil(); #endif } JANET_CORE_FN(os_posix_chroot, "(os/posix-chroot dirname)", "Call `chroot` to change the root directory to `dirname`. " "Not supported on all systems (POSIX only).") { janet_sandbox_assert(JANET_SANDBOX_CHROOT); janet_fixarity(argc, 1); #if defined(JANET_WINDOWS) || defined(JANET_PLAN9) (void) argv; janet_panic("not supported on Windows or Plan 9"); #else const char *root = janet_getcstring(argv, 0); int result; do { result = chroot(root); } while (result == -1 && errno == EINTR); if (result == -1) { janet_panic(janet_strerror(errno)); } return janet_wrap_nil(); #endif } #ifdef JANET_EV /* Runs in a separate thread */ static JanetEVGenericMessage os_shell_subr(JanetEVGenericMessage args) { int stat = system((const char *) args.argp); janet_free(args.argp); if (args.argi) { args.tag = JANET_EV_TCTAG_INTEGER; } else { args.tag = JANET_EV_TCTAG_BOOLEAN; } args.argi = stat; return args; } #endif JANET_CORE_FN(os_shell, "(os/shell str)", "Pass a command string str directly to the system shell.") { janet_sandbox_assert(JANET_SANDBOX_SUBPROCESS); janet_arity(argc, 0, 1); const char *cmd = argc ? janet_getcstring(argv, 0) : NULL; #ifdef JANET_EV janet_ev_threaded_await(os_shell_subr, 0, argc, cmd ? strdup(cmd) : NULL); #else int stat = system(cmd); return argc ? janet_wrap_integer(stat) : janet_wrap_boolean(stat); #endif } #endif /* JANET_NO_PROCESSES */ #ifndef JANET_PLAN9 JANET_CORE_FN(os_environ, "(os/environ)", "Get a copy of the OS environment table.") { janet_sandbox_assert(JANET_SANDBOX_ENV); (void) argv; janet_fixarity(argc, 0); int32_t nenv = 0; janet_lock_environ(); char **env = environ; while (*env++) nenv += 1; JanetTable *t = janet_table(nenv); for (int32_t i = 0; i < nenv; i++) { char *e = environ[i]; char *eq = strchr(e, '='); if (!eq) { janet_unlock_environ(); janet_panic("no '=' in environ"); } char *v = eq + 1; int32_t full_len = (int32_t) strlen(e); int32_t val_len = (int32_t) strlen(v); janet_table_put( t, janet_stringv((const uint8_t *)e, full_len - val_len - 1), janet_stringv((const uint8_t *)v, val_len) ); } janet_unlock_environ(); return janet_wrap_table(t); } #endif JANET_CORE_FN(os_getenv, "(os/getenv variable &opt dflt)", "Get the string value of an environment variable.") { janet_sandbox_assert(JANET_SANDBOX_ENV); janet_arity(argc, 1, 2); const char *cstr = janet_getcstring(argv, 0); janet_lock_environ(); const char *res = getenv(cstr); Janet ret = res ? janet_cstringv(res) : argc == 2 ? argv[1] : janet_wrap_nil(); janet_unlock_environ(); return ret; } JANET_CORE_FN(os_setenv, "(os/setenv variable value)", "Set an environment variable.") { #ifdef JANET_WINDOWS #define SETENV(K,V) _putenv_s(K, V) #define UNSETENV(K) _putenv_s(K, "") #elif defined(JANET_PLAN9) #define SETENV(K,V) putenv(K, V) #define UNSETENV(K) unsetenv(K) #else #define SETENV(K,V) setenv(K, V, 1) #define UNSETENV(K) unsetenv(K) #endif janet_sandbox_assert(JANET_SANDBOX_ENV); janet_arity(argc, 1, 2); const char *ks = janet_getcstring(argv, 0); const char *vs = janet_optcstring(argv, argc, 1, NULL); janet_lock_environ(); if (NULL == vs) { UNSETENV(ks); } else { SETENV(ks, vs); } janet_unlock_environ(); return janet_wrap_nil(); } JANET_CORE_FN(os_time, "(os/time)", "Get the current time expressed as the number of whole seconds since " "January 1, 1970, the Unix epoch. Returns a real number.") { janet_fixarity(argc, 0); (void) argv; double dtime = (double)(time(NULL)); return janet_wrap_number(dtime); } JANET_CORE_FN(os_clock, "(os/clock &opt source format)", "Return the current time of the requested clock source.\n\n" "The `source` argument selects the clock source to use, when not specified the default " "is `:realtime`:\n" "- :realtime: Return the real (i.e., wall-clock) time. This clock is affected by discontinuous " " jumps in the system time\n" "- :monotonic: Return the number of whole + fractional seconds since some fixed point in " " time. The clock is guaranteed to be non-decreasing in real time.\n" "- :cputime: Return the CPU time consumed by this process (i.e. all threads in the process)\n" "The `format` argument selects the type of output, when not specified the default is `:double`:\n" "- :double: Return the number of seconds + fractional seconds as a double\n" "- :int: Return the number of seconds as an integer\n" "- :tuple: Return a 2 integer tuple [seconds, nanoseconds]\n") { enum JanetTimeSource source; janet_sandbox_assert(JANET_SANDBOX_HRTIME); janet_arity(argc, 0, 2); JanetKeyword sourcestr = janet_optkeyword(argv, argc, 0, NULL); if (sourcestr == NULL || janet_cstrcmp(sourcestr, "realtime") == 0) { source = JANET_TIME_REALTIME; } else if (janet_cstrcmp(sourcestr, "monotonic") == 0) { source = JANET_TIME_MONOTONIC; } else if (janet_cstrcmp(sourcestr, "cputime") == 0) { source = JANET_TIME_CPUTIME; } else { janet_panicf("expected :realtime, :monotonic, or :cputime, got %v", argv[0]); } struct timespec tv; if (janet_gettime(&tv, source)) janet_panic("could not get time"); JanetKeyword formatstr = janet_optkeyword(argv, argc, 1, NULL); if (formatstr == NULL || janet_cstrcmp(formatstr, "double") == 0) { double dtime = (double)(tv.tv_sec + (tv.tv_nsec / 1E9)); return janet_wrap_number(dtime); } else if (janet_cstrcmp(formatstr, "int") == 0) { return janet_wrap_number((double)(tv.tv_sec)); } else if (janet_cstrcmp(formatstr, "tuple") == 0) { Janet tup[2] = {janet_wrap_number((double)tv.tv_sec), janet_wrap_number((double)tv.tv_nsec) }; return janet_wrap_tuple(janet_tuple_n(tup, 2)); } else { janet_panicf("expected :double, :int, or :tuple, got %v", argv[1]); } } JANET_CORE_FN(os_sleep, "(os/sleep n)", "Suspend the program for `n` seconds. `n` can be a real number. Returns " "nil.") { janet_fixarity(argc, 1); double delay = janet_getnumber(argv, 0); if (delay < 0) janet_panic("invalid argument to sleep"); #ifdef JANET_WINDOWS Sleep((DWORD)(delay * 1000)); #else int rc; struct timespec ts; ts.tv_sec = (time_t) delay; ts.tv_nsec = (delay <= UINT32_MAX) ? (long)((delay - ((uint32_t)delay)) * 1000000000) : 0; RETRY_EINTR(rc, nanosleep(&ts, &ts)); #endif return janet_wrap_nil(); } JANET_CORE_FN(os_isatty, "(os/isatty &opt file)", "Returns true if `file` is a terminal. If `file` is not specified, " "it will default to standard output.") { janet_arity(argc, 0, 1); FILE *f = (argc == 1) ? janet_getfile(argv, 0, NULL) : stdout; #ifdef JANET_WINDOWS int fd = _fileno(f); if (fd == -1) janet_panic("not a valid stream"); return janet_wrap_boolean(_isatty(fd)); #else int fd = fileno(f); if (fd == -1) janet_panic(janet_strerror(errno)); return janet_wrap_boolean(isatty(fd)); #endif } JANET_CORE_FN(os_cwd, "(os/cwd)", "Returns the current working directory.") { janet_fixarity(argc, 0); (void) argv; char buf[FILENAME_MAX]; char *ptr; #ifdef JANET_WINDOWS ptr = _getcwd(buf, FILENAME_MAX); #else ptr = getcwd(buf, FILENAME_MAX); #endif if (NULL == ptr) janet_panic("could not get current directory"); return janet_cstringv(ptr); } JANET_CORE_FN(os_cryptorand, "(os/cryptorand n &opt buf)", "Get or append `n` bytes of good quality random data provided by the OS. Returns a new buffer or `buf`.") { JanetBuffer *buffer; janet_arity(argc, 1, 2); int32_t offset; int32_t n = janet_getinteger(argv, 0); if (n < 0) janet_panic("expected positive integer"); if (argc == 2) { buffer = janet_getbuffer(argv, 1); offset = buffer->count; } else { offset = 0; buffer = janet_buffer(n); } /* We could optimize here by adding setcount_uninit */ janet_buffer_setcount(buffer, offset + n); if (janet_cryptorand(buffer->data + offset, n) != 0) janet_panic("unable to get sufficient random data"); return janet_wrap_buffer(buffer); } /* Helper function to get given or current time as local or UTC struct tm. * - arg n+0: optional time_t to be converted, uses current time if not given * - arg n+1: optional truthy to indicate the convnersion uses local time */ static struct tm *time_to_tm(const Janet *argv, int32_t argc, int32_t n, struct tm *t_infos) { time_t t; if (argc > n && !janet_checktype(argv[n], JANET_NIL)) { int64_t integer = janet_getinteger64(argv, n); t = (time_t) integer; } else { time(&t); } struct tm *t_info = NULL; if (argc > n + 1 && janet_truthy(argv[n + 1])) { /* local time */ #ifdef JANET_WINDOWS _tzset(); localtime_s(t_infos, &t); t_info = t_infos; #elif defined(JANET_PLAN9) t_info = localtime(&t); #else tzset(); t_info = localtime_r(&t, t_infos); #endif } else { /* utc time */ #ifdef JANET_WINDOWS gmtime_s(t_infos, &t); t_info = t_infos; #elif defined(JANET_PLAN9) t_info = gmtime(&t); #else t_info = gmtime_r(&t, t_infos); #endif } return t_info; } JANET_CORE_FN(os_date, "(os/date &opt time local)", "Returns the given time as a date struct, or the current time if `time` is not given. " "Date is given in UTC unless `local` is truthy, in which case the date is formatted for " "the local timezone. Returns a struct with following key values. Note that all numbers are 0-indexed.\n\n" "* :seconds - number of seconds [0-61]\n\n" "* :minutes - number of minutes [0-59]\n\n" "* :hours - number of hours [0-23]\n\n" "* :month-day - day of month [0-30]\n\n" "* :month - month of year [0, 11]\n\n" "* :year - years since year 0 (e.g. 2019)\n\n" "* :week-day - day of the week [0-6]\n\n" "* :year-day - day of the year [0-365]\n\n" "* :dst - if Day Light Savings is in effect\n\n" "You can set local timezone by setting TZ environment variable. " "See tzset() or _tzset() for further details.") { janet_arity(argc, 0, 2); (void) argv; struct tm t_infos; struct tm *t_info = time_to_tm(argv, argc, 0, &t_infos); JanetKV *st = janet_struct_begin(9); janet_struct_put(st, janet_ckeywordv("seconds"), janet_wrap_number(t_info->tm_sec)); janet_struct_put(st, janet_ckeywordv("minutes"), janet_wrap_number(t_info->tm_min)); janet_struct_put(st, janet_ckeywordv("hours"), janet_wrap_number(t_info->tm_hour)); janet_struct_put(st, janet_ckeywordv("month-day"), janet_wrap_number(t_info->tm_mday - 1)); janet_struct_put(st, janet_ckeywordv("month"), janet_wrap_number(t_info->tm_mon)); janet_struct_put(st, janet_ckeywordv("year"), janet_wrap_number(t_info->tm_year + 1900)); janet_struct_put(st, janet_ckeywordv("week-day"), janet_wrap_number(t_info->tm_wday)); janet_struct_put(st, janet_ckeywordv("year-day"), janet_wrap_number(t_info->tm_yday)); janet_struct_put(st, janet_ckeywordv("dst"), janet_wrap_boolean(t_info->tm_isdst)); return janet_wrap_struct(janet_struct_end(st)); } #define SIZETIMEFMT 250 JANET_CORE_FN(os_strftime, "(os/strftime fmt &opt time local)", "Format the given time as a string, or the current time if `time` is not given. " "The time is formatted according to the same rules as the ISO C89 function strftime(). " "The time is formatted in UTC unless `local` is truthy, in which case the date is formatted for " "the local timezone. You can set local timezone by setting TZ environment variable. " "See tzset() or _tzset() for further details.") { janet_arity(argc, 1, 3); const char *fmt = janet_getcstring(argv, 0); /* ANSI X3.159-1989, section 4.12.3.5 "The strftime function" */ static const char *valid = "aAbBcdHIjmMpSUwWxXyYZ%"; const char *p = fmt; while (*p) { if (*p++ == '%') { if (!*p) { janet_panic("invalid conversion specifier"); } if (!strchr(valid, *p)) { janet_panicf("invalid conversion specifier '%%%c'", *p); } p++; } } struct tm t_infos; struct tm *t_info = time_to_tm(argv, argc, 1, &t_infos); char buf[SIZETIMEFMT]; (void)strftime(buf, sizeof(buf), fmt, t_info); return janet_cstringv(buf); } static int entry_getdst(Janet env_entry) { Janet v; if (janet_checktype(env_entry, JANET_TABLE)) { JanetTable *entry = janet_unwrap_table(env_entry); v = janet_table_get_keyword(entry, "dst"); } else if (janet_checktype(env_entry, JANET_STRUCT)) { const JanetKV *entry = janet_unwrap_struct(env_entry); v = janet_struct_get(entry, janet_ckeywordv("dst")); } else { v = janet_wrap_nil(); } if (janet_checktype(v, JANET_NIL)) { return -1; } else { return janet_truthy(v); } } #ifdef JANET_WINDOWS typedef int32_t timeint_t; #else typedef int64_t timeint_t; #endif static timeint_t entry_getint(Janet env_entry, char *field) { Janet i; if (janet_checktype(env_entry, JANET_TABLE)) { JanetTable *entry = janet_unwrap_table(env_entry); i = janet_table_get_keyword(entry, field); } else if (janet_checktype(env_entry, JANET_STRUCT)) { const JanetKV *entry = janet_unwrap_struct(env_entry); i = janet_struct_get(entry, janet_ckeywordv(field)); } else { return 0; } if (janet_checktype(i, JANET_NIL)) { return 0; } #ifdef JANET_WINDOWS if (!janet_checkint(i)) { janet_panicf("bad slot #%s, expected 32 bit signed integer, got %v", field, i); } #else if (!janet_checkint64(i)) { janet_panicf("bad slot #%s, expected 64 bit signed integer, got %v", field, i); } #endif return (timeint_t)janet_unwrap_number(i); } JANET_CORE_FN(os_mktime, "(os/mktime date-struct &opt local)", "Get the broken down date-struct time expressed as the number " "of seconds since January 1, 1970, the Unix epoch. " "Returns a real number. " "Date is given in UTC unless `local` is truthy, in which case the " "date is computed for the local timezone.\n\n" "Inverse function to os/date.") { janet_arity(argc, 1, 2); time_t t; struct tm t_info; /* Use memset instead of = {0} to silence paranoid warning in macos */ memset(&t_info, 0, sizeof(t_info)); if (!janet_checktype(argv[0], JANET_TABLE) && !janet_checktype(argv[0], JANET_STRUCT)) janet_panic_type(argv[0], 0, JANET_TFLAG_DICTIONARY); t_info.tm_sec = entry_getint(argv[0], "seconds"); t_info.tm_min = entry_getint(argv[0], "minutes"); t_info.tm_hour = entry_getint(argv[0], "hours"); t_info.tm_mday = entry_getint(argv[0], "month-day") + 1; t_info.tm_mon = entry_getint(argv[0], "month"); t_info.tm_year = entry_getint(argv[0], "year") - 1900; t_info.tm_isdst = entry_getdst(argv[0]); if (argc >= 2 && janet_truthy(argv[1])) { /* local time */ t = mktime(&t_info); } else { /* utc time */ #ifdef JANET_NO_UTC_MKTIME janet_panic("os/mktime UTC not supported on this platform"); #else t = timegm(&t_info); #endif } if (t == (time_t) -1) { janet_panicf("%s", janet_strerror(errno)); } return janet_wrap_number((double)t); } #ifdef JANET_NO_SYMLINKS #define j_symlink link #else #define j_symlink symlink #endif #ifndef JANET_NO_LOCALES JANET_CORE_FN(os_setlocale, "(os/setlocale &opt locale category)", "Set the system locale, which affects how dates and numbers are formatted. " "Passing nil to locale will return the current locale. Category can be one of:\n\n" " * :all (default)\n" " * :collate\n" " * :ctype\n" " * :monetary\n" " * :numeric\n" " * :time\n\n" "Returns the new locale if set successfully, otherwise nil. Note that this will affect " "other functions such as `os/strftime` and even `printf`.") { janet_arity(argc, 0, 2); const char *locale_name = janet_optcstring(argv, argc, 0, NULL); int category_int = LC_ALL; if (argc > 1 && !janet_checktype(argv[1], JANET_NIL)) { if (janet_keyeq(argv[1], "all")) { category_int = LC_ALL; } else if (janet_keyeq(argv[1], "collate")) { category_int = LC_COLLATE; } else if (janet_keyeq(argv[1], "ctype")) { category_int = LC_CTYPE; } else if (janet_keyeq(argv[1], "monetary")) { category_int = LC_MONETARY; } else if (janet_keyeq(argv[1], "numeric")) { category_int = LC_NUMERIC; } else if (janet_keyeq(argv[1], "time")) { category_int = LC_TIME; } else { janet_panicf("expected one of :all, :collate, :ctype, :monetary, :numeric, or :time, got %v", argv[1]); } } const char *old = setlocale(category_int, locale_name); if (old == NULL) return janet_wrap_nil(); return janet_cstringv(old); } #endif JANET_CORE_FN(os_link, "(os/link oldpath newpath &opt symlink)", "Create a link at newpath that points to oldpath and returns nil. " "Iff symlink is truthy, creates a symlink. " "Iff symlink is falsey or not provided, " "creates a hard link. Does not work on Windows or Plan 9.") { janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); janet_arity(argc, 2, 3); #if defined(JANET_WINDOWS) || defined(JANET_PLAN9) (void) argc; (void) argv; janet_panic("not supported on Windows or Plan 9"); #else const char *oldpath = janet_getcstring(argv, 0); const char *newpath = janet_getcstring(argv, 1); int res = ((argc == 3 && janet_truthy(argv[2])) ? j_symlink : link)(oldpath, newpath); if (-1 == res) janet_panicf("%s: %s -> %s", janet_strerror(errno), oldpath, newpath); return janet_wrap_nil(); #endif } JANET_CORE_FN(os_symlink, "(os/symlink oldpath newpath)", "Create a symlink from oldpath to newpath, returning nil. Same as `(os/link oldpath newpath true)`.") { janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); janet_fixarity(argc, 2); #if defined(JANET_WINDOWS) || defined(JANET_PLAN9) (void) argc; (void) argv; janet_panic("not supported on Windows or Plan 9"); #else const char *oldpath = janet_getcstring(argv, 0); const char *newpath = janet_getcstring(argv, 1); int res = j_symlink(oldpath, newpath); if (-1 == res) janet_panicf("%s: %s -> %s", janet_strerror(errno), oldpath, newpath); return janet_wrap_nil(); #endif } #undef j_symlink JANET_CORE_FN(os_mkdir, "(os/mkdir path)", "Create a new directory. The path will be relative to the current directory if relative, otherwise " "it will be an absolute path. Returns true if the directory was created, false if the directory already exists, and " "errors otherwise.") { janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); janet_fixarity(argc, 1); const char *path = janet_getcstring(argv, 0); #ifdef JANET_WINDOWS int res = _mkdir(path); #else int res = mkdir(path, S_IRUSR | S_IWUSR | S_IXUSR | S_IRGRP | S_IWGRP | S_IXGRP | S_IROTH | S_IXOTH); #endif if (res == 0) return janet_wrap_true(); if (errno == EEXIST) return janet_wrap_false(); janet_panicf("%s: %s", janet_strerror(errno), path); } JANET_CORE_FN(os_rmdir, "(os/rmdir path)", "Delete a directory. The directory must be empty to succeed.") { janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); janet_fixarity(argc, 1); const char *path = janet_getcstring(argv, 0); #ifdef JANET_WINDOWS int res = _rmdir(path); #elif defined(JANET_PLAN9) int res = remove(path); #else int res = rmdir(path); #endif if (-1 == res) janet_panicf("%s: %s", janet_strerror(errno), path); return janet_wrap_nil(); } JANET_CORE_FN(os_cd, "(os/cd path)", "Change current directory to path. Returns nil on success, errors on failure.") { janet_sandbox_assert(JANET_SANDBOX_FS_READ); janet_fixarity(argc, 1); const char *path = janet_getcstring(argv, 0); #ifdef JANET_WINDOWS int res = _chdir(path); #else int res = chdir(path); #endif if (-1 == res) janet_panicf("%s: %s", janet_strerror(errno), path); return janet_wrap_nil(); } JANET_CORE_FN(os_touch, "(os/touch path &opt actime modtime)", "Update the access time and modification times for a file. By default, sets " "times to the current time.") { janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); janet_arity(argc, 1, 3); const char *path = janet_getcstring(argv, 0); struct utimbuf timebuf, *bufp; if (argc >= 2) { bufp = &timebuf; timebuf.actime = (time_t) janet_getnumber(argv, 1); if (argc >= 3) { timebuf.modtime = (time_t) janet_getnumber(argv, 2); } else { timebuf.modtime = timebuf.actime; } } else { bufp = NULL; } int res = utime(path, bufp); if (-1 == res) janet_panic(janet_strerror(errno)); return janet_wrap_nil(); } JANET_CORE_FN(os_remove, "(os/rm path)", "Delete a file. Returns nil.") { janet_fixarity(argc, 1); const char *path = janet_getcstring(argv, 0); int status = remove(path); if (-1 == status) janet_panicf("%s: %s", janet_strerror(errno), path); return janet_wrap_nil(); } #ifndef JANET_NO_SYMLINKS JANET_CORE_FN(os_readlink, "(os/readlink path)", "Read the contents of a symbolic link. Does not work on Windows.\n") { janet_fixarity(argc, 1); #ifdef JANET_WINDOWS (void) argc; (void) argv; janet_panic("not supported on Windows"); #else static char buffer[PATH_MAX]; const char *path = janet_getcstring(argv, 0); ssize_t len = readlink(path, buffer, sizeof buffer); if (len < 0 || (size_t)len >= sizeof buffer) janet_panicf("%s: %s", janet_strerror(errno), path); return janet_stringv((const uint8_t *)buffer, len); #endif } #endif #ifdef JANET_WINDOWS typedef struct _stat jstat_t; typedef unsigned short jmode_t; static int32_t janet_perm_to_unix(unsigned short m) { int32_t ret = 0; if (m & S_IEXEC) ret |= 0111; if (m & S_IWRITE) ret |= 0222; if (m & S_IREAD) ret |= 0444; return ret; } static unsigned short janet_perm_from_unix(int32_t x) { unsigned short m = 0; if (x & 111) m |= S_IEXEC; if (x & 222) m |= S_IWRITE; if (x & 444) m |= S_IREAD; return m; } static const uint8_t *janet_decode_mode(unsigned short m) { const char *str = "other"; if (m & _S_IFREG) str = "file"; else if (m & _S_IFDIR) str = "directory"; else if (m & _S_IFCHR) str = "character"; return janet_ckeyword(str); } static int32_t janet_decode_permissions(jmode_t mode) { return (int32_t)(mode & (S_IEXEC | S_IWRITE | S_IREAD)); } #else typedef struct stat jstat_t; typedef mode_t jmode_t; static int32_t janet_perm_to_unix(mode_t m) { return (int32_t) m; } static mode_t janet_perm_from_unix(int32_t x) { return (mode_t) x; } static const uint8_t *janet_decode_mode(mode_t m) { const char *str = "other"; if (S_ISREG(m)) str = "file"; else if (S_ISDIR(m)) str = "directory"; #ifndef JANET_PLAN9 else if (S_ISFIFO(m)) str = "fifo"; else if (S_ISBLK(m)) str = "block"; else if (S_ISSOCK(m)) str = "socket"; else if (S_ISLNK(m)) str = "link"; else if (S_ISCHR(m)) str = "character"; #endif return janet_ckeyword(str); } static int32_t janet_decode_permissions(jmode_t mode) { return (int32_t)(mode & 0777); } #endif static int32_t os_parse_permstring(const uint8_t *perm) { int32_t m = 0; if (perm[0] == 'r') m |= 0400; if (perm[1] == 'w') m |= 0200; if (perm[2] == 'x') m |= 0100; if (perm[3] == 'r') m |= 0040; if (perm[4] == 'w') m |= 0020; if (perm[5] == 'x') m |= 0010; if (perm[6] == 'r') m |= 0004; if (perm[7] == 'w') m |= 0002; if (perm[8] == 'x') m |= 0001; return m; } static Janet os_make_permstring(int32_t permissions) { uint8_t bytes[9] = {0}; bytes[0] = (permissions & 0400) ? 'r' : '-'; bytes[1] = (permissions & 0200) ? 'w' : '-'; bytes[2] = (permissions & 0100) ? 'x' : '-'; bytes[3] = (permissions & 0040) ? 'r' : '-'; bytes[4] = (permissions & 0020) ? 'w' : '-'; bytes[5] = (permissions & 0010) ? 'x' : '-'; bytes[6] = (permissions & 0004) ? 'r' : '-'; bytes[7] = (permissions & 0002) ? 'w' : '-'; bytes[8] = (permissions & 0001) ? 'x' : '-'; return janet_stringv(bytes, sizeof(bytes)); } static int32_t os_get_unix_mode(const Janet *argv, int32_t n) { int32_t unix_mode; if (janet_checkint(argv[n])) { /* Integer mode */ int32_t x = janet_unwrap_integer(argv[n]); if (x < 0 || x > 0777) { janet_panicf("bad slot #%d, expected integer in range [0, 8r777], got %v", n, argv[n]); } unix_mode = x; } else { /* Bytes mode */ JanetByteView bytes = janet_getbytes(argv, n); if (bytes.len != 9) { janet_panicf("bad slot #%d: expected byte sequence of length 9, got %v", n, argv[n]); } unix_mode = os_parse_permstring(bytes.bytes); } return unix_mode; } static jmode_t os_getmode(const Janet *argv, int32_t n) { return janet_perm_from_unix(os_get_unix_mode(argv, n)); } /* Getters */ static Janet os_stat_dev(jstat_t *st) { return janet_wrap_number(st->st_dev); } static Janet os_stat_inode(jstat_t *st) { return janet_wrap_number(st->st_ino); } static Janet os_stat_mode(jstat_t *st) { return janet_wrap_keyword(janet_decode_mode(st->st_mode)); } static Janet os_stat_int_permissions(jstat_t *st) { return janet_wrap_integer(janet_perm_to_unix(janet_decode_permissions(st->st_mode))); } static Janet os_stat_permissions(jstat_t *st) { return os_make_permstring(janet_perm_to_unix(janet_decode_permissions(st->st_mode))); } static Janet os_stat_uid(jstat_t *st) { return janet_wrap_number(st->st_uid); } static Janet os_stat_gid(jstat_t *st) { return janet_wrap_number(st->st_gid); } static Janet os_stat_nlink(jstat_t *st) { return janet_wrap_number(st->st_nlink); } static Janet os_stat_rdev(jstat_t *st) { return janet_wrap_number(st->st_rdev); } static Janet os_stat_size(jstat_t *st) { return janet_wrap_number(st->st_size); } static Janet os_stat_accessed(jstat_t *st) { return janet_wrap_number((double) st->st_atime); } static Janet os_stat_modified(jstat_t *st) { return janet_wrap_number((double) st->st_mtime); } static Janet os_stat_changed(jstat_t *st) { return janet_wrap_number((double) st->st_ctime); } #ifdef JANET_WINDOWS static Janet os_stat_blocks(jstat_t *st) { (void) st; return janet_wrap_number(0); } static Janet os_stat_blocksize(jstat_t *st) { (void) st; return janet_wrap_number(0); } #else static Janet os_stat_blocks(jstat_t *st) { return janet_wrap_number(st->st_blocks); } static Janet os_stat_blocksize(jstat_t *st) { return janet_wrap_number(st->st_blksize); } #endif struct OsStatGetter { const char *name; Janet(*fn)(jstat_t *st); }; static const struct OsStatGetter os_stat_getters[] = { {"dev", os_stat_dev}, {"inode", os_stat_inode}, {"mode", os_stat_mode}, {"int-permissions", os_stat_int_permissions}, {"permissions", os_stat_permissions}, {"uid", os_stat_uid}, {"gid", os_stat_gid}, {"nlink", os_stat_nlink}, {"rdev", os_stat_rdev}, {"size", os_stat_size}, {"blocks", os_stat_blocks}, {"blocksize", os_stat_blocksize}, {"accessed", os_stat_accessed}, {"modified", os_stat_modified}, {"changed", os_stat_changed}, {NULL, NULL} }; static Janet os_stat_or_lstat(int do_lstat, int32_t argc, Janet *argv) { janet_sandbox_assert(JANET_SANDBOX_FS_READ); janet_arity(argc, 1, 2); const char *path = janet_getcstring(argv, 0); JanetTable *tab = NULL; const uint8_t *key = NULL; if (argc == 2) { if (janet_checktype(argv[1], JANET_KEYWORD)) { key = janet_getkeyword(argv, 1); } else { tab = janet_gettable(argv, 1); } } else { tab = janet_table(0); } /* Build result */ jstat_t st; #ifdef JANET_WINDOWS (void) do_lstat; int res = _stat(path, &st); #elif defined(JANET_PLAN9) (void)do_lstat; int res = stat(path, &st); #else int res; if (do_lstat) { res = lstat(path, &st); } else { res = stat(path, &st); } #endif if (-1 == res) { return janet_wrap_nil(); } if (NULL == key) { /* Put results in table */ for (const struct OsStatGetter *sg = os_stat_getters; sg->name != NULL; sg++) { janet_table_put(tab, janet_ckeywordv(sg->name), sg->fn(&st)); } return janet_wrap_table(tab); } else { /* Get one result */ for (const struct OsStatGetter *sg = os_stat_getters; sg->name != NULL; sg++) { if (janet_cstrcmp(key, sg->name)) continue; return sg->fn(&st); } janet_panicf("unexpected keyword %v", janet_wrap_keyword(key)); } } JANET_CORE_FN(os_stat, "(os/stat path &opt tab|key)", "Gets information about a file or directory. Returns a table if the second argument is a keyword, returns " "only that information from stat. If the file or directory does not exist, returns nil. The keys are:\n\n" "* :dev - the device that the file is on\n\n" "* :mode - the type of file, one of :file, :directory, :block, :character, :fifo, :socket, :link, or :other\n\n" "* :int-permissions - A Unix permission integer like 8r744\n\n" "* :permissions - A Unix permission string like \"rwxr--r--\"\n\n" "* :uid - File uid\n\n" "* :gid - File gid\n\n" "* :nlink - number of links to file\n\n" "* :rdev - Real device of file. 0 on Windows\n\n" "* :size - size of file in bytes\n\n" "* :blocks - number of blocks in file. 0 on Windows\n\n" "* :blocksize - size of blocks in file. 0 on Windows\n\n" "* :accessed - timestamp when file last accessed\n\n" "* :changed - timestamp when file last changed (permissions changed)\n\n" "* :modified - timestamp when file last modified (content changed)\n") { return os_stat_or_lstat(0, argc, argv); } JANET_CORE_FN(os_lstat, "(os/lstat path &opt tab|key)", "Like os/stat, but don't follow symlinks.\n") { return os_stat_or_lstat(1, argc, argv); } JANET_CORE_FN(os_chmod, "(os/chmod path mode)", "Change file permissions, where `mode` is a permission string as returned by " "`os/perm-string`, or an integer as returned by `os/perm-int`. " "When `mode` is an integer, it is interpreted as a Unix permission value, best specified in octal, like " "8r666 or 8r400. Windows will not differentiate between user, group, and other permissions, and thus will combine all of these permissions. Returns nil." "Unsupported on plan9.") { janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); janet_fixarity(argc, 2); #ifdef JANET_PLAN9 janet_panic("not supported on Plan 9"); #else const char *path = janet_getcstring(argv, 0); #ifdef JANET_WINDOWS int res = _chmod(path, os_getmode(argv, 1)); #else int res = chmod(path, os_getmode(argv, 1)); #endif if (-1 == res) janet_panicf("%s: %s", janet_strerror(errno), path); return janet_wrap_nil(); #endif } #ifndef JANET_NO_UMASK JANET_CORE_FN(os_umask, "(os/umask mask)", "Set a new umask, returns the old umask.") { janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); janet_fixarity(argc, 1); int mask = (int) os_getmode(argv, 0); #ifdef JANET_WINDOWS int res = _umask(mask); #else int res = umask(mask); #endif return janet_wrap_integer(janet_perm_to_unix(res)); } #endif JANET_CORE_FN(os_dir, "(os/dir dir &opt array)", "Iterate over files and subdirectories in a directory. Returns an array of paths parts, " "with only the file name or directory name and no prefix.") { janet_sandbox_assert(JANET_SANDBOX_FS_READ); janet_arity(argc, 1, 2); const char *dir = janet_getcstring(argv, 0); JanetArray *paths = (argc == 2) ? janet_getarray(argv, 1) : janet_array(0); #ifdef JANET_WINDOWS /* Read directory items with FindFirstFile / FindNextFile / FindClose */ struct _finddata_t afile; char pattern[MAX_PATH + 1]; if (strlen(dir) > (sizeof(pattern) - 3)) janet_panicf("path too long: %s", dir); snprintf(pattern, sizeof(pattern), "%s/*", dir); intptr_t res = _findfirst(pattern, &afile); if (-1 == res) janet_panicv(janet_cstringv(janet_strerror(errno))); do { if (strcmp(".", afile.name) && strcmp("..", afile.name)) { janet_array_push(paths, janet_cstringv(afile.name)); } } while (_findnext(res, &afile) != -1); _findclose(res); #else /* Read directory items with opendir / readdir / closedir */ struct dirent *dp; DIR *dfd = opendir(dir); if (dfd == NULL) janet_panicf("cannot open directory %s: %s", dir, janet_strerror(errno)); for (;;) { errno = 0; dp = readdir(dfd); if (dp == NULL) { if (errno) { int olderr = errno; closedir(dfd); janet_panicf("failed to read directory %s: %s", dir, janet_strerror(olderr)); } break; } if (!strcmp(dp->d_name, ".") || !strcmp(dp->d_name, "..")) { continue; } janet_array_push(paths, janet_cstringv(dp->d_name)); } closedir(dfd); #endif return janet_wrap_array(paths); } JANET_CORE_FN(os_rename, "(os/rename oldname newname)", "Rename a file on disk to a new path. Returns nil.") { janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); janet_fixarity(argc, 2); const char *src = janet_getcstring(argv, 0); const char *dest = janet_getcstring(argv, 1); int status = rename(src, dest); if (status) { janet_panic(janet_strerror(errno)); } return janet_wrap_nil(); } JANET_CORE_FN(os_realpath, "(os/realpath path)", "Get the absolute path for a given path, following ../, ./, and symlinks. " "Returns an absolute path as a string.") { janet_sandbox_assert(JANET_SANDBOX_FS_READ); janet_fixarity(argc, 1); const char *src = janet_getcstring(argv, 0); #ifdef JANET_NO_REALPATH janet_panic("os/realpath not enabled for this platform"); #else #ifdef JANET_WINDOWS char *dest = _fullpath(NULL, src, _MAX_PATH); #else char *dest = realpath(src, NULL); #endif if (NULL == dest) janet_panicf("%s: %s", janet_strerror(errno), src); Janet ret = janet_cstringv(dest); #ifdef JANET_WINDOWS DWORD attrib = GetFileAttributes(dest); free(dest); /* if janet_malloc is redefined, still use free to correspond with _fullpath */ if (attrib == INVALID_FILE_ATTRIBUTES) { janet_panicf("path does not exist: %v", ret); } #else janet_free(dest); #endif return ret; #endif } JANET_CORE_FN(os_permission_string, "(os/perm-string int)", "Convert a Unix octal permission value from a permission integer as returned by `os/stat` " "to a human readable string, that follows the formatting " "of Unix tools like `ls`. Returns the string as a 9-character string of r, w, x and - characters. Does not " "include the file/directory/symlink character as rendered by `ls`.") { janet_fixarity(argc, 1); return os_make_permstring(os_get_unix_mode(argv, 0)); } JANET_CORE_FN(os_permission_int, "(os/perm-int bytes)", "Parse a 9-character permission string and return an integer that can be used by chmod.") { janet_fixarity(argc, 1); return janet_wrap_integer(os_get_unix_mode(argv, 0)); } #ifdef JANET_EV /* * Define a few functions on streams the require JANET_EV to be defined. */ static jmode_t os_optmode(int32_t argc, const Janet *argv, int32_t n, int32_t dflt) { if (argc > n) return os_getmode(argv, n); return janet_perm_from_unix(dflt); } JANET_CORE_FN(os_open, "(os/open path &opt flags mode)", "Create a stream from a file, like the POSIX open system call. Returns a new stream. " "`mode` should be a file mode as passed to `os/chmod`, but only if the create flag is given. " "The default mode is 8r666. " "Allowed flags are as follows:\n\n" " * :r - open this file for reading\n" " * :w - open this file for writing\n" " * :c - create a new file (O\\_CREATE)\n" " * :e - fail if the file exists (O\\_EXCL)\n" " * :t - shorten an existing file to length 0 (O\\_TRUNC)\n\n" " * :a - append to a file (O\\_APPEND on posix, FILE_APPEND_DATA on windows)\n" "Posix-only flags:\n\n" " * :x - O\\_SYNC\n" " * :C - O\\_NOCTTY\n\n" " * :N - Turn off O\\_NONBLOCK and disable ev reading/writing\n\n" "Windows-only flags:\n\n" " * :R - share reads (FILE\\_SHARE\\_READ)\n" " * :W - share writes (FILE\\_SHARE\\_WRITE)\n" " * :D - share deletes (FILE\\_SHARE\\_DELETE)\n" " * :H - FILE\\_ATTRIBUTE\\_HIDDEN\n" " * :O - FILE\\_ATTRIBUTE\\_READONLY\n" " * :F - FILE\\_ATTRIBUTE\\_OFFLINE\n" " * :T - FILE\\_ATTRIBUTE\\_TEMPORARY\n" " * :d - FILE\\_FLAG\\_DELETE\\_ON\\_CLOSE\n" " * :V - Turn off FILE\\_FLAG\\_OVERLAPPED and disable ev reading/writing\n" " * :I - set bInheritHandle on the created file so it can be passed to other processes.\n" " * :b - FILE\\_FLAG\\_NO\\_BUFFERING\n") { janet_arity(argc, 1, 3); const char *path = janet_getcstring(argv, 0); const uint8_t *opt_flags = janet_optkeyword(argv, argc, 1, (const uint8_t *) "r"); jmode_t mode = os_optmode(argc, argv, 2, 0666); uint32_t stream_flags = 0; int disable_stream_mode = 0; JanetHandle fd; #ifdef JANET_WINDOWS (void) mode; int inherited_handle = 0; DWORD desiredAccess = 0; DWORD shareMode = 0; DWORD creationDisp = 0; DWORD fileFlags = FILE_FLAG_OVERLAPPED; DWORD fileAttributes = 0; /* We map unix-like open flags to the creationDisp parameter */ int creatUnix = 0; #define OCREAT 1 #define OEXCL 2 #define OTRUNC 4 for (const uint8_t *c = opt_flags; *c; c++) { switch (*c) { default: break; case 'r': desiredAccess |= GENERIC_READ; stream_flags |= JANET_STREAM_READABLE; janet_sandbox_assert(JANET_SANDBOX_FS_READ); break; case 'w': desiredAccess |= GENERIC_WRITE; stream_flags |= JANET_STREAM_WRITABLE; janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); break; case 'a': desiredAccess |= FILE_APPEND_DATA; stream_flags |= JANET_STREAM_WRITABLE; janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); break; case 'c': creatUnix |= OCREAT; janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); break; case 'e': creatUnix |= OEXCL; break; case 't': creatUnix |= OTRUNC; janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); break; /* Windows only flags */ case 'D': shareMode |= FILE_SHARE_DELETE; break; case 'R': shareMode |= FILE_SHARE_READ; break; case 'W': shareMode |= FILE_SHARE_WRITE; break; case 'H': fileAttributes |= FILE_ATTRIBUTE_HIDDEN; break; case 'O': fileAttributes |= FILE_ATTRIBUTE_READONLY; break; case 'F': fileAttributes |= FILE_ATTRIBUTE_OFFLINE; break; case 'T': fileAttributes |= FILE_ATTRIBUTE_TEMPORARY; break; case 'd': fileFlags |= FILE_FLAG_DELETE_ON_CLOSE; break; case 'b': fileFlags |= FILE_FLAG_NO_BUFFERING; break; case 'I': inherited_handle = 1; break; case 'V': fileFlags &= ~FILE_FLAG_OVERLAPPED; disable_stream_mode = 1; break; /* we could potentially add more here - * https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilea */ } } switch (creatUnix) { default: janet_panic("invalid creation flags"); case 0: creationDisp = OPEN_EXISTING; break; case OCREAT: creationDisp = OPEN_ALWAYS; break; case OCREAT + OEXCL: creationDisp = CREATE_NEW; break; case OCREAT + OTRUNC: creationDisp = CREATE_ALWAYS; break; case OTRUNC: creationDisp = TRUNCATE_EXISTING; break; } if (fileAttributes == 0) { fileAttributes = FILE_ATTRIBUTE_NORMAL; } SECURITY_ATTRIBUTES saAttr; memset(&saAttr, 0, sizeof(saAttr)); saAttr.nLength = sizeof(saAttr); if (inherited_handle) { saAttr.bInheritHandle = TRUE; /* Needed to do interesting things with file */ } fd = CreateFileA(path, desiredAccess, shareMode, &saAttr, creationDisp, fileFlags | fileAttributes, NULL); if (fd == INVALID_HANDLE_VALUE) janet_panicv(janet_ev_lasterr()); #else int open_flags = O_NONBLOCK; #ifdef JANET_LINUX open_flags |= O_CLOEXEC; #endif int read_flag = 0; int write_flag = 0; for (const uint8_t *c = opt_flags; *c; c++) { switch (*c) { default: break; case 'r': read_flag = 1; stream_flags |= JANET_STREAM_READABLE; janet_sandbox_assert(JANET_SANDBOX_FS_READ); break; case 'w': write_flag = 1; stream_flags |= JANET_STREAM_WRITABLE; janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); break; case 'c': open_flags |= O_CREAT; janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); break; case 'e': open_flags |= O_EXCL; break; case 't': open_flags |= O_TRUNC; janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); break; /* posix only */ case 'x': open_flags |= O_SYNC; break; case 'C': open_flags |= O_NOCTTY; break; case 'a': open_flags |= O_APPEND; break; case 'N': open_flags &= ~O_NONBLOCK; disable_stream_mode = 1; break; } } /* If both read and write, fix up to O_RDWR */ if (read_flag && !write_flag) { open_flags |= O_RDONLY; } else if (write_flag && !read_flag) { open_flags |= O_WRONLY; } else { open_flags |= O_RDWR; } do { fd = open(path, open_flags, mode); } while (fd == -1 && errno == EINTR); if (fd == -1) janet_panicv(janet_ev_lasterr()); #endif return janet_wrap_abstract(janet_stream(fd, disable_stream_mode ? 0 : stream_flags, NULL)); } JANET_CORE_FN(os_pipe, "(os/pipe &opt flags)", "Create a readable stream and a writable stream that are connected. Returns a two-element " "tuple where the first element is a readable stream and the second element is the writable " "stream. `flags` is a keyword set of flags to disable non-blocking settings on the ends of the pipe. " "This may be desired if passing the pipe to a subprocess with `os/spawn`.\n\n" "* :W - sets the writable end of the pipe to a blocking stream.\n" "* :R - sets the readable end of the pipe to a blocking stream.\n\n" "By default, both ends of the pipe are non-blocking for use with the `ev` module.") { (void) argv; janet_arity(argc, 0, 1); JanetHandle fds[2]; int flags = 0; if (argc > 0 && !janet_checktype(argv[0], JANET_NIL)) { flags = (int) janet_getflags(argv, 0, "WR"); } if (janet_make_pipe(fds, flags)) janet_panicv(janet_ev_lasterr()); JanetStream *reader = janet_stream(fds[0], (flags & 2) ? 0 : JANET_STREAM_READABLE, NULL); JanetStream *writer = janet_stream(fds[1], (flags & 1) ? 0 : JANET_STREAM_WRITABLE, NULL); Janet tup[2] = {janet_wrap_abstract(reader), janet_wrap_abstract(writer)}; return janet_wrap_tuple(janet_tuple_n(tup, 2)); } #endif #endif /* JANET_REDUCED_OS */ /* Module entry point */ void janet_lib_os(JanetTable *env) { #if !defined(JANET_REDUCED_OS) && defined(JANET_WINDOWS) && defined(JANET_THREADS) /* During start up, the top-most abstract machine (thread) * in the thread tree sets up the critical section. */ static volatile long env_lock_initializing = 0; static volatile long env_lock_initialized = 0; if (!InterlockedExchange(&env_lock_initializing, 1)) { InitializeCriticalSection(&env_lock); InterlockedOr(&env_lock_initialized, 1); } else { while (!InterlockedOr(&env_lock_initialized, 0)) { Sleep(0); } } #endif #ifndef JANET_NO_PROCESSES #endif JanetRegExt os_cfuns[] = { JANET_CORE_REG("os/exit", os_exit), JANET_CORE_REG("os/which", os_which), JANET_CORE_REG("os/arch", os_arch), JANET_CORE_REG("os/compiler", os_compiler), #ifndef JANET_REDUCED_OS /* misc (un-sandboxed) */ JANET_CORE_REG("os/cpu-count", os_cpu_count), JANET_CORE_REG("os/cwd", os_cwd), JANET_CORE_REG("os/cryptorand", os_cryptorand), JANET_CORE_REG("os/perm-string", os_permission_string), JANET_CORE_REG("os/perm-int", os_permission_int), JANET_CORE_REG("os/mktime", os_mktime), JANET_CORE_REG("os/time", os_time), /* not high resolution */ JANET_CORE_REG("os/date", os_date), /* not high resolution */ JANET_CORE_REG("os/strftime", os_strftime), JANET_CORE_REG("os/sleep", os_sleep), JANET_CORE_REG("os/isatty", os_isatty), #ifndef JANET_NO_LOCALES JANET_CORE_REG("os/setlocale", os_setlocale), #endif /* env functions */ #ifndef JANET_PLAN9 JANET_CORE_REG("os/environ", os_environ), #endif JANET_CORE_REG("os/getenv", os_getenv), JANET_CORE_REG("os/setenv", os_setenv), /* fs read */ JANET_CORE_REG("os/dir", os_dir), JANET_CORE_REG("os/stat", os_stat), JANET_CORE_REG("os/lstat", os_lstat), JANET_CORE_REG("os/chmod", os_chmod), JANET_CORE_REG("os/touch", os_touch), JANET_CORE_REG("os/realpath", os_realpath), JANET_CORE_REG("os/cd", os_cd), #ifndef JANET_NO_UMASK JANET_CORE_REG("os/umask", os_umask), #endif #ifndef JANET_NO_SYMLINKS JANET_CORE_REG("os/readlink", os_readlink), #endif /* fs write */ JANET_CORE_REG("os/mkdir", os_mkdir), JANET_CORE_REG("os/rmdir", os_rmdir), JANET_CORE_REG("os/rm", os_remove), JANET_CORE_REG("os/link", os_link), JANET_CORE_REG("os/rename", os_rename), #ifndef JANET_NO_SYMLINKS JANET_CORE_REG("os/symlink", os_symlink), #endif /* processes */ #ifndef JANET_NO_PROCESSES JANET_CORE_REG("os/execute", os_execute), JANET_CORE_REG("os/spawn", os_spawn), JANET_CORE_REG("os/shell", os_shell), JANET_CORE_REG("os/posix-fork", os_posix_fork), JANET_CORE_REG("os/posix-exec", os_posix_exec), JANET_CORE_REG("os/posix-chroot", os_posix_chroot), /* no need to sandbox process management if you can't create processes * (allows for limited functionality if use exposes C-functions to create specific processes) */ JANET_CORE_REG("os/proc-wait", os_proc_wait), JANET_CORE_REG("os/proc-kill", os_proc_kill), JANET_CORE_REG("os/proc-close", os_proc_close), JANET_CORE_REG("os/getpid", os_proc_getpid), #ifdef JANET_EV JANET_CORE_REG("os/sigaction", os_sigaction), #endif #endif /* high resolution timers */ JANET_CORE_REG("os/clock", os_clock), #ifdef JANET_EV JANET_CORE_REG("os/open", os_open), /* fs read and write */ JANET_CORE_REG("os/pipe", os_pipe), #endif #endif JANET_REG_END }; janet_core_cfuns_ext(env, NULL, os_cfuns); } janet-1.41.2/src/core/parse.c000066400000000000000000001270641514534607600157220ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "util.h" #endif #define JANET_PARSER_DEAD 0x1 #define JANET_PARSER_GENERATED_ERROR 0x2 /* Check if a character is whitespace */ static int is_whitespace(uint8_t c) { return c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\0' || c == '\v' || c == '\f'; } /* Code generated by tools/symcharsgen.c. * The table contains 256 bits, where each bit is 1 * if the corresponding ascii code is a symbol char, and 0 * if not. The upper characters are also considered symbol * chars and are then checked for utf-8 compliance. */ static const uint32_t symchars[8] = { 0x00000000, 0xf7ffec72, 0xc7ffffff, 0x07fffffe, 0xffffffff, 0xffffffff, 0xffffffff, 0xffffffff }; /* Check if a character is a valid symbol character * symbol chars are A-Z, a-z, 0-9, or one of !$&*+-./:<=>@\^_| */ int janet_is_symbol_char(uint8_t c) { return symchars[c >> 5] & ((uint32_t)1 << (c & 0x1F)); } /* Validate some utf8. Useful for identifiers. Only validates * the encoding, does not check for valid code points (they * are less well defined than the encoding). */ int janet_valid_utf8(const uint8_t *str, int32_t len) { int32_t i = 0; int32_t j; while (i < len) { int32_t nexti; uint8_t c = str[i]; /* Check the number of bytes in code point */ if (c < 0x80) nexti = i + 1; else if ((c >> 5) == 0x06) nexti = i + 2; else if ((c >> 4) == 0x0E) nexti = i + 3; else if ((c >> 3) == 0x1E) nexti = i + 4; /* Don't allow 5 or 6 byte code points */ else return 0; /* No overflow */ if (nexti > len) return 0; /* Ensure trailing bytes are well formed (10XX XXXX) */ for (j = i + 1; j < nexti; j++) { if ((str[j] >> 6) != 2) return 0; } /* Check for overlong encoding */ if ((nexti == i + 2) && str[i] < 0xC2) return 0; if ((str[i] == 0xE0) && str[i + 1] < 0xA0) return 0; if ((str[i] == 0xF0) && str[i + 1] < 0x90) return 0; i = nexti; } return 1; } /* Get hex digit from a letter */ static int to_hex(uint8_t c) { if (c >= '0' && c <= '9') { return c - '0'; } else if (c >= 'A' && c <= 'F') { return 10 + c - 'A'; } else if (c >= 'a' && c <= 'f') { return 10 + c - 'a'; } else { return -1; } } /* Define a stack on the main parser struct */ #define DEF_PARSER_STACK(NAME, T, STACK, STACKCOUNT, STACKCAP) \ static void NAME(JanetParser *p, T x) { \ size_t oldcount = p->STACKCOUNT; \ size_t newcount = oldcount + 1; \ if (newcount > p->STACKCAP) { \ T *next; \ size_t newcap = 2 * newcount; \ next = janet_realloc(p->STACK, sizeof(T) * newcap); \ if (NULL == next) { \ JANET_OUT_OF_MEMORY; \ } \ p->STACK = next; \ p->STACKCAP = newcap; \ } \ p->STACK[oldcount] = x; \ p->STACKCOUNT = newcount; \ } DEF_PARSER_STACK(push_buf, uint8_t, buf, bufcount, bufcap) DEF_PARSER_STACK(push_arg, Janet, args, argcount, argcap) DEF_PARSER_STACK(_pushstate, JanetParseState, states, statecount, statecap) #undef DEF_PARSER_STACK #define PFLAG_CONTAINER 0x100 #define PFLAG_BUFFER 0x200 #define PFLAG_PARENS 0x400 #define PFLAG_SQRBRACKETS 0x800 #define PFLAG_CURLYBRACKETS 0x1000 #define PFLAG_STRING 0x2000 #define PFLAG_LONGSTRING 0x4000 #define PFLAG_READERMAC 0x8000 #define PFLAG_ATSYM 0x10000 #define PFLAG_COMMENT 0x20000 #define PFLAG_TOKEN 0x40000 static void pushstate(JanetParser *p, Consumer consumer, int flags) { JanetParseState s; s.counter = 0; s.argn = 0; s.flags = flags; s.consumer = consumer; s.line = p->line; s.column = p->column; _pushstate(p, s); } static void popstate(JanetParser *p, Janet val) { for (;;) { JanetParseState top = p->states[--p->statecount]; JanetParseState *newtop = p->states + p->statecount - 1; /* Source mapping info */ if (janet_checktype(val, JANET_TUPLE)) { janet_tuple_sm_line(janet_unwrap_tuple(val)) = (int32_t) top.line; janet_tuple_sm_column(janet_unwrap_tuple(val)) = (int32_t) top.column; } if (newtop->flags & PFLAG_CONTAINER) { newtop->argn++; /* Keep track of number of values in the root state */ if (p->statecount == 1) { p->pending++; /* Root items are always wrapped in a tuple for source map info. */ const Janet *tup = janet_tuple_n(&val, 1); janet_tuple_sm_line(tup) = (int32_t) top.line; janet_tuple_sm_column(tup) = (int32_t) top.column; val = janet_wrap_tuple(tup); } push_arg(p, val); return; } else if (newtop->flags & PFLAG_READERMAC) { Janet *t = janet_tuple_begin(2); int c = newtop->flags & 0xFF; const char *which = (c == '\'') ? "quote" : (c == ',') ? "unquote" : (c == ';') ? "splice" : (c == '|') ? "short-fn" : (c == '~') ? "quasiquote" : ""; t[0] = janet_csymbolv(which); t[1] = val; /* Quote source mapping info */ janet_tuple_sm_line(t) = (int32_t) newtop->line; janet_tuple_sm_column(t) = (int32_t) newtop->column; val = janet_wrap_tuple(janet_tuple_end(t)); } else { return; } } } static void delim_error(JanetParser *parser, size_t stack_index, char c, const char *msg) { JanetParseState *s = parser->states + stack_index; JanetBuffer *buffer = janet_buffer(40); if (msg) { janet_buffer_push_cstring(buffer, msg); } if (c) { janet_buffer_push_u8(buffer, c); } if (stack_index > 0) { janet_buffer_push_cstring(buffer, ", "); if (s->flags & PFLAG_PARENS) { janet_buffer_push_u8(buffer, '('); } else if (s->flags & PFLAG_SQRBRACKETS) { janet_buffer_push_u8(buffer, '['); } else if (s->flags & PFLAG_CURLYBRACKETS) { janet_buffer_push_u8(buffer, '{'); } else if (s->flags & PFLAG_STRING) { janet_buffer_push_u8(buffer, '"'); } else if (s->flags & PFLAG_LONGSTRING) { int32_t i; for (i = 0; i < s->argn; i++) { janet_buffer_push_u8(buffer, '`'); } } janet_formatb(buffer, " opened at line %d, column %d", (int32_t) s->line, (int32_t) s->column); } parser->error = (const char *) janet_string(buffer->data, buffer->count); parser->flag |= JANET_PARSER_GENERATED_ERROR; } static int checkescape(uint8_t c) { switch (c) { default: return -1; case 'x': case 'u': case 'U': return 1; case 'n': return '\n'; case 't': return '\t'; case 'r': return '\r'; case '0': return '\0'; case 'z': return '\0'; case 'f': return '\f'; case 'v': return '\v'; case 'a': return '\a'; case 'b': return '\b'; case '\'': return '\''; case '?': return '?'; case 'e': return 27; case '"': return '"'; case '\\': return '\\'; } } /* Forward declare */ static int stringchar(JanetParser *p, JanetParseState *state, uint8_t c); static void write_codepoint(JanetParser *p, int32_t codepoint) { if (codepoint <= 0x7F) { push_buf(p, (uint8_t) codepoint); } else if (codepoint <= 0x7FF) { push_buf(p, (uint8_t)((codepoint >> 6) & 0x1F) | 0xC0); push_buf(p, (uint8_t)((codepoint >> 0) & 0x3F) | 0x80); } else if (codepoint <= 0xFFFF) { push_buf(p, (uint8_t)((codepoint >> 12) & 0x0F) | 0xE0); push_buf(p, (uint8_t)((codepoint >> 6) & 0x3F) | 0x80); push_buf(p, (uint8_t)((codepoint >> 0) & 0x3F) | 0x80); } else { push_buf(p, (uint8_t)((codepoint >> 18) & 0x07) | 0xF0); push_buf(p, (uint8_t)((codepoint >> 12) & 0x3F) | 0x80); push_buf(p, (uint8_t)((codepoint >> 6) & 0x3F) | 0x80); push_buf(p, (uint8_t)((codepoint >> 0) & 0x3F) | 0x80); } } static int escapeh(JanetParser *p, JanetParseState *state, uint8_t c) { int digit = to_hex(c); if (digit < 0) { p->error = "invalid hex digit in hex escape"; return 1; } state->argn = (state->argn << 4) + digit; state->counter--; if (!state->counter) { push_buf(p, (uint8_t)(state->argn & 0xFF)); state->argn = 0; state->consumer = stringchar; } return 1; } static int escapeu(JanetParser *p, JanetParseState *state, uint8_t c) { int digit = to_hex(c); if (digit < 0) { p->error = "invalid hex digit in unicode escape"; return 1; } state->argn = (state->argn << 4) + digit; state->counter--; if (!state->counter) { if (state->argn > 0x10FFFF) { p->error = "invalid unicode codepoint"; return 1; } write_codepoint(p, state->argn); state->argn = 0; state->consumer = stringchar; } return 1; } static int escape1(JanetParser *p, JanetParseState *state, uint8_t c) { int e = checkescape(c); if (e < 0) { p->error = "invalid string escape sequence"; return 1; } if (c == 'x') { state->counter = 2; state->argn = 0; state->consumer = escapeh; } else if (c == 'u' || c == 'U') { state->counter = c == 'u' ? 4 : 6; state->argn = 0; state->consumer = escapeu; } else { push_buf(p, (uint8_t) e); state->consumer = stringchar; } return 1; } static int stringend(JanetParser *p, JanetParseState *state) { Janet ret; uint8_t *bufstart = p->buf; int32_t buflen = (int32_t) p->bufcount; if (state->flags & PFLAG_LONGSTRING) { /* Post process to remove leading whitespace */ JanetParseState top = p->states[p->statecount - 1]; int32_t indent_col = (int32_t) top.column - 1; uint8_t *r = bufstart, *end = r + buflen; /* Unless there are only spaces before EOLs, disable reindenting */ int reindent = 1; while (reindent && (r < end)) { if (*r++ == '\n') { for (int32_t j = 0; (r < end) && (*r != '\n') && (j < indent_col); j++, r++) { if (*r != ' ') { reindent = 0; break; } } if ((r + 1) < end && *r == '\r' && *(r + 1) == '\n') reindent = 1; } } /* Now reindent if able */ if (reindent) { uint8_t *w = bufstart; r = bufstart; while (r < end) { if (*r == '\n') { *w++ = *r++; for (int32_t j = 0; (r < end) && (*r != '\n') && (j < indent_col); j++, r++); if ((r + 1) < end && *r == '\r' && *(r + 1) == '\n') *w++ = *r++; } else { *w++ = *r++; } } buflen = (int32_t)(w - bufstart); } /* Check for leading EOL so we can remove it */ if (buflen > 1 && bufstart[0] == '\r' && bufstart[1] == '\n') { /* Windows EOL */ buflen = buflen - 2; bufstart = bufstart + 2; } else if (buflen > 0 && bufstart[0] == '\n') { /* Unix EOL */ buflen--; bufstart++; } /* Check for trailing EOL so we can remove it */ if (buflen > 1 && bufstart[buflen - 2] == '\r' && bufstart[buflen - 1] == '\n') { /* Windows EOL */ buflen = buflen - 2; } else if (buflen > 0 && bufstart[buflen - 1] == '\n') { /* Unix EOL */ buflen--; } } if (state->flags & PFLAG_BUFFER) { JanetBuffer *b = janet_buffer(buflen); janet_buffer_push_bytes(b, bufstart, buflen); ret = janet_wrap_buffer(b); } else { ret = janet_wrap_string(janet_string(bufstart, buflen)); } p->bufcount = 0; popstate(p, ret); return 1; } static int stringchar(JanetParser *p, JanetParseState *state, uint8_t c) { /* Enter escape */ if (c == '\\') { state->consumer = escape1; return 1; } /* String end */ if (c == '"') { return stringend(p, state); } /* normal char */ if (c != '\n' && c != '\r') push_buf(p, c); return 1; } /* Check for string equality in the buffer */ static int check_str_const(const char *cstr, const uint8_t *str, int32_t len) { int32_t index; for (index = 0; index < len; index++) { uint8_t c = str[index]; uint8_t k = ((const uint8_t *)cstr)[index]; if (c < k) return -1; if (c > k) return 1; if (k == '\0') break; } return (cstr[index] == '\0') ? 0 : -1; } static int tokenchar(JanetParser *p, JanetParseState *state, uint8_t c) { Janet ret; double numval; int32_t blen; if (janet_is_symbol_char(c)) { push_buf(p, (uint8_t) c); if (c > 127) state->argn = 1; /* Use to indicate non ascii */ return 1; } /* Token finished */ blen = (int32_t) p->bufcount; int start_dig = p->buf[0] >= '0' && p->buf[0] <= '9'; int start_num = start_dig || p->buf[0] == '-' || p->buf[0] == '+' || p->buf[0] == '.'; if (p->buf[0] == ':') { /* Don't do full utf-8 check unless we have seen non ascii characters. */ int valid = (!state->argn) || janet_valid_utf8(p->buf + 1, blen - 1); if (!valid) { p->error = "invalid utf-8 in keyword"; return 0; } ret = janet_keywordv(p->buf + 1, blen - 1); #ifdef JANET_INT_TYPES } else if (start_num && !janet_scan_numeric(p->buf, blen, &ret)) { (void) numval; #else } else if (start_num && !janet_scan_number(p->buf, blen, &numval)) { ret = janet_wrap_number(numval); #endif } else if (!check_str_const("nil", p->buf, blen)) { ret = janet_wrap_nil(); } else if (!check_str_const("false", p->buf, blen)) { ret = janet_wrap_false(); } else if (!check_str_const("true", p->buf, blen)) { ret = janet_wrap_true(); } else { if (start_dig) { p->error = "symbol literal cannot start with a digit"; return 0; } else { /* Don't do full utf-8 check unless we have seen non ascii characters. */ int valid = (!state->argn) || janet_valid_utf8(p->buf, blen); if (!valid) { p->error = "invalid utf-8 in symbol"; return 0; } ret = janet_symbolv(p->buf, blen); } } p->bufcount = 0; popstate(p, ret); return 0; } static int comment(JanetParser *p, JanetParseState *state, uint8_t c) { (void) state; if (c == '\n') { p->statecount--; p->bufcount = 0; } else { push_buf(p, c); } return 1; } static Janet close_tuple(JanetParser *p, JanetParseState *state, int32_t flag) { Janet *ret = janet_tuple_begin(state->argn); janet_tuple_flag(ret) |= flag; for (int32_t i = state->argn - 1; i >= 0; i--) ret[i] = p->args[--p->argcount]; return janet_wrap_tuple(janet_tuple_end(ret)); } static Janet close_array(JanetParser *p, JanetParseState *state) { JanetArray *array = janet_array(state->argn); for (int32_t i = state->argn - 1; i >= 0; i--) array->data[i] = p->args[--p->argcount]; array->count = state->argn; return janet_wrap_array(array); } static Janet close_struct(JanetParser *p, JanetParseState *state) { JanetKV *st = janet_struct_begin(state->argn >> 1); for (size_t i = p->argcount - state->argn; i < p->argcount; i += 2) { Janet key = p->args[i]; Janet value = p->args[i + 1]; janet_struct_put(st, key, value); } p->argcount -= state->argn; return janet_wrap_struct(janet_struct_end(st)); } static Janet close_table(JanetParser *p, JanetParseState *state) { JanetTable *table = janet_table(state->argn >> 1); for (size_t i = p->argcount - state->argn; i < p->argcount; i += 2) { Janet key = p->args[i]; Janet value = p->args[i + 1]; janet_table_put(table, key, value); } p->argcount -= state->argn; return janet_wrap_table(table); } #define PFLAG_INSTRING 0x100000 #define PFLAG_END_CANDIDATE 0x200000 static int longstring(JanetParser *p, JanetParseState *state, uint8_t c) { if (state->flags & PFLAG_INSTRING) { /* We are inside the long string */ if (c == '`') { state->flags |= PFLAG_END_CANDIDATE; state->flags &= ~PFLAG_INSTRING; state->counter = 1; /* Use counter to keep track of number of '=' seen */ return 1; } push_buf(p, c); return 1; } else if (state->flags & PFLAG_END_CANDIDATE) { int i; /* We are checking a potential end of the string */ if (state->counter == state->argn) { stringend(p, state); return 0; } if (c == '`' && state->counter < state->argn) { state->counter++; return 1; } /* Failed end candidate */ for (i = 0; i < state->counter; i++) { push_buf(p, '`'); } push_buf(p, c); state->counter = 0; state->flags &= ~PFLAG_END_CANDIDATE; state->flags |= PFLAG_INSTRING; return 1; } else { /* We are at beginning of string */ state->argn++; if (c != '`') { state->flags |= PFLAG_INSTRING; push_buf(p, c); } return 1; } } static int root(JanetParser *p, JanetParseState *state, uint8_t c); static int atsign(JanetParser *p, JanetParseState *state, uint8_t c) { (void) state; p->statecount--; switch (c) { case '{': pushstate(p, root, PFLAG_CONTAINER | PFLAG_CURLYBRACKETS | PFLAG_ATSYM); return 1; case '"': pushstate(p, stringchar, PFLAG_BUFFER | PFLAG_STRING); return 1; case '`': pushstate(p, longstring, PFLAG_BUFFER | PFLAG_LONGSTRING); return 1; case '[': pushstate(p, root, PFLAG_CONTAINER | PFLAG_SQRBRACKETS | PFLAG_ATSYM); return 1; case '(': pushstate(p, root, PFLAG_CONTAINER | PFLAG_PARENS | PFLAG_ATSYM); return 1; default: break; } pushstate(p, tokenchar, PFLAG_TOKEN); push_buf(p, '@'); /* Push the leading at-sign that was dropped */ return 0; } /* The root state of the parser */ static int root(JanetParser *p, JanetParseState *state, uint8_t c) { switch (c) { default: if (is_whitespace(c)) return 1; if (!janet_is_symbol_char(c)) { p->error = "unexpected character"; return 1; } pushstate(p, tokenchar, PFLAG_TOKEN); return 0; case '\'': case ',': case ';': case '~': case '|': pushstate(p, root, PFLAG_READERMAC | c); return 1; case '"': pushstate(p, stringchar, PFLAG_STRING); return 1; case '#': pushstate(p, comment, PFLAG_COMMENT); return 1; case '@': pushstate(p, atsign, PFLAG_ATSYM); return 1; case '`': pushstate(p, longstring, PFLAG_LONGSTRING); return 1; case ')': case ']': case '}': { Janet ds; if (p->statecount == 1) { delim_error(p, 0, c, "unexpected closing delimiter "); return 1; } if ((c == ')' && (state->flags & PFLAG_PARENS)) || (c == ']' && (state->flags & PFLAG_SQRBRACKETS))) { if (state->flags & PFLAG_ATSYM) { ds = close_array(p, state); } else { ds = close_tuple(p, state, c == ']' ? JANET_TUPLE_FLAG_BRACKETCTOR : 0); } } else if (c == '}' && (state->flags & PFLAG_CURLYBRACKETS)) { if (state->argn & 1) { p->error = "struct and table literals expect even number of arguments"; return 1; } if (state->flags & PFLAG_ATSYM) { ds = close_table(p, state); } else { ds = close_struct(p, state); } } else { delim_error(p, p->statecount - 1, c, "mismatched delimiter "); return 1; } popstate(p, ds); } return 1; case '(': pushstate(p, root, PFLAG_CONTAINER | PFLAG_PARENS); return 1; case '[': pushstate(p, root, PFLAG_CONTAINER | PFLAG_SQRBRACKETS); return 1; case '{': pushstate(p, root, PFLAG_CONTAINER | PFLAG_CURLYBRACKETS); return 1; } } static void janet_parser_checkdead(JanetParser *parser) { if (parser->flag) janet_panic("parser is dead, cannot consume"); if (parser->error) janet_panic("parser has unchecked error, cannot consume"); } /* Public API */ void janet_parser_consume(JanetParser *parser, uint8_t c) { int consumed = 0; janet_parser_checkdead(parser); if (c == '\r') { parser->line++; parser->column = 0; } else if (c == '\n') { parser->column = 0; if (parser->lookback != '\r') parser->line++; } else { parser->column++; } while (!consumed && !parser->error) { JanetParseState *state = parser->states + parser->statecount - 1; consumed = state->consumer(parser, state, c); } parser->lookback = c; } void janet_parser_eof(JanetParser *parser) { janet_parser_checkdead(parser); size_t oldcolumn = parser->column; size_t oldline = parser->line; janet_parser_consume(parser, '\n'); if (parser->statecount > 1) { delim_error(parser, parser->statecount - 1, 0, "unexpected end of source"); } parser->line = oldline; parser->column = oldcolumn; parser->flag |= JANET_PARSER_DEAD; } enum JanetParserStatus janet_parser_status(JanetParser *parser) { if (parser->error) return JANET_PARSE_ERROR; if (parser->flag) return JANET_PARSE_DEAD; if (parser->statecount > 1) return JANET_PARSE_PENDING; return JANET_PARSE_ROOT; } void janet_parser_flush(JanetParser *parser) { parser->argcount = 0; parser->statecount = 1; parser->bufcount = 0; parser->pending = 0; } const char *janet_parser_error(JanetParser *parser) { enum JanetParserStatus status = janet_parser_status(parser); if (status == JANET_PARSE_ERROR) { const char *e = parser->error; parser->error = NULL; parser->flag &= ~JANET_PARSER_GENERATED_ERROR; janet_parser_flush(parser); return e; } return NULL; } Janet janet_parser_produce(JanetParser *parser) { Janet ret; size_t i; if (parser->pending == 0) return janet_wrap_nil(); ret = janet_unwrap_tuple(parser->args[0])[0]; for (i = 1; i < parser->argcount; i++) { parser->args[i - 1] = parser->args[i]; } parser->pending--; parser->argcount--; parser->states[0].argn--; return ret; } Janet janet_parser_produce_wrapped(JanetParser *parser) { Janet ret; size_t i; if (parser->pending == 0) return janet_wrap_nil(); ret = parser->args[0]; for (i = 1; i < parser->argcount; i++) { parser->args[i - 1] = parser->args[i]; } parser->pending--; parser->argcount--; parser->states[0].argn--; return ret; } void janet_parser_init(JanetParser *parser) { parser->args = NULL; parser->states = NULL; parser->buf = NULL; parser->argcount = 0; parser->argcap = 0; parser->bufcount = 0; parser->bufcap = 0; parser->statecount = 0; parser->statecap = 0; parser->error = NULL; parser->lookback = -1; parser->line = 1; parser->column = 0; parser->pending = 0; parser->flag = 0; pushstate(parser, root, PFLAG_CONTAINER); } void janet_parser_deinit(JanetParser *parser) { janet_free(parser->args); janet_free(parser->buf); janet_free(parser->states); } void janet_parser_clone(const JanetParser *src, JanetParser *dest) { /* Misc fields */ dest->flag = src->flag; dest->pending = src->pending; dest->lookback = src->lookback; dest->line = src->line; dest->column = src->column; dest->error = src->error; /* Keep counts */ dest->argcount = src->argcount; dest->bufcount = src->bufcount; dest->statecount = src->statecount; /* Capacities are equal to counts */ dest->bufcap = dest->bufcount; dest->statecap = dest->statecount; dest->argcap = dest->argcount; /* Deep cloned fields */ dest->args = NULL; dest->states = NULL; dest->buf = NULL; if (dest->bufcap) { dest->buf = janet_malloc(dest->bufcap); if (!dest->buf) goto nomem; memcpy(dest->buf, src->buf, dest->bufcap); } if (dest->argcap) { dest->args = janet_malloc(sizeof(Janet) * dest->argcap); if (!dest->args) goto nomem; memcpy(dest->args, src->args, dest->argcap * sizeof(Janet)); } if (dest->statecap) { dest->states = janet_malloc(sizeof(JanetParseState) * dest->statecap); if (!dest->states) goto nomem; memcpy(dest->states, src->states, dest->statecap * sizeof(JanetParseState)); } return; nomem: JANET_OUT_OF_MEMORY; } int janet_parser_has_more(JanetParser *parser) { return !!parser->pending; } /* C functions */ static int parsermark(void *p, size_t size) { size_t i; JanetParser *parser = (JanetParser *)p; (void) size; for (i = 0; i < parser->argcount; i++) { janet_mark(parser->args[i]); } if (parser->flag & JANET_PARSER_GENERATED_ERROR) { janet_mark(janet_wrap_string((const uint8_t *) parser->error)); } return 0; } static int parsergc(void *p, size_t size) { JanetParser *parser = (JanetParser *)p; (void) size; janet_parser_deinit(parser); return 0; } static int parserget(void *p, Janet key, Janet *out); static Janet parsernext(void *p, Janet key); const JanetAbstractType janet_parser_type = { "core/parser", parsergc, parsermark, parserget, NULL, /* put */ NULL, /* marshal */ NULL, /* unmarshal */ NULL, /* tostring */ NULL, /* compare */ NULL, /* hash */ parsernext, JANET_ATEND_NEXT }; /* C Function parser */ JANET_CORE_FN(cfun_parse_parser, "(parser/new)", "Creates and returns a new parser object. Parsers are state machines " "that can receive bytes and generate a stream of values.") { (void) argv; janet_fixarity(argc, 0); JanetParser *p = janet_abstract(&janet_parser_type, sizeof(JanetParser)); janet_parser_init(p); return janet_wrap_abstract(p); } JANET_CORE_FN(cfun_parse_consume, "(parser/consume parser bytes &opt index)", "Input bytes into the parser and parse them. Will not throw errors " "if there is a parse error. Starts at the byte index given by `index`. Returns " "the number of bytes read.") { janet_arity(argc, 2, 3); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); JanetByteView view = janet_getbytes(argv, 1); if (argc == 3) { int32_t offset = janet_getinteger(argv, 2); if (offset < 0 || offset > view.len) janet_panicf("invalid offset %d out of range [0,%d]", offset, view.len); view.len -= offset; view.bytes += offset; } int32_t i; for (i = 0; i < view.len; i++) { janet_parser_consume(p, view.bytes[i]); switch (janet_parser_status(p)) { case JANET_PARSE_ROOT: case JANET_PARSE_PENDING: break; default: return janet_wrap_integer(i + 1); } } return janet_wrap_integer(i); } JANET_CORE_FN(cfun_parse_eof, "(parser/eof parser)", "Indicate to the parser that the end of file was reached. This puts the parser in the :dead state.") { janet_fixarity(argc, 1); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); janet_parser_eof(p); return argv[0]; } JANET_CORE_FN(cfun_parse_insert, "(parser/insert parser value)", "Insert a value into the parser. This means that the parser state can be manipulated " "in between chunks of bytes. This would allow a user to add extra elements to arrays " "and tuples, for example. Returns the parser.") { janet_fixarity(argc, 2); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); JanetParseState *s = p->states + p->statecount - 1; if (s->consumer == tokenchar) { janet_parser_consume(p, ' '); p->column--; s = p->states + p->statecount - 1; } if (s->flags & PFLAG_COMMENT) s--; if (s->flags & PFLAG_CONTAINER) { s->argn++; if (p->statecount == 1) { p->pending++; Janet tup = janet_wrap_tuple(janet_tuple_n(argv + 1, 1)); push_arg(p, tup); } else { push_arg(p, argv[1]); } } else if (s->flags & (PFLAG_STRING | PFLAG_LONGSTRING)) { const uint8_t *str = janet_to_string(argv[1]); int32_t slen = janet_string_length(str); size_t newcount = p->bufcount + slen; if (p->bufcap < newcount) { size_t newcap = 2 * newcount; p->buf = janet_realloc(p->buf, newcap); if (p->buf == NULL) { JANET_OUT_OF_MEMORY; } p->bufcap = newcap; } safe_memcpy(p->buf + p->bufcount, str, slen); p->bufcount = newcount; } else { janet_panic("cannot insert value into parser"); } return argv[0]; } JANET_CORE_FN(cfun_parse_has_more, "(parser/has-more parser)", "Check if the parser has more values in the value queue.") { janet_fixarity(argc, 1); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); return janet_wrap_boolean(janet_parser_has_more(p)); } JANET_CORE_FN(cfun_parse_byte, "(parser/byte parser b)", "Input a single byte `b` into the parser byte stream. Returns the parser.") { janet_fixarity(argc, 2); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); int32_t i = janet_getinteger(argv, 1); janet_parser_consume(p, 0xFF & i); return argv[0]; } JANET_CORE_FN(cfun_parse_status, "(parser/status parser)", "Gets the current status of the parser state machine. The status will " "be one of:\n\n" "* :pending - a value is being parsed.\n\n" "* :error - a parsing error was encountered.\n\n" "* :root - the parser can either read more values or safely terminate.") { janet_fixarity(argc, 1); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); const char *stat = NULL; switch (janet_parser_status(p)) { case JANET_PARSE_PENDING: stat = "pending"; break; case JANET_PARSE_ERROR: stat = "error"; break; case JANET_PARSE_ROOT: stat = "root"; break; case JANET_PARSE_DEAD: stat = "dead"; break; } return janet_ckeywordv(stat); } JANET_CORE_FN(cfun_parse_error, "(parser/error parser)", "If the parser is in the error state, returns the message associated with " "that error. Otherwise, returns nil. Also flushes the parser state and parser " "queue, so be sure to handle everything in the queue before calling " "`parser/error`.") { janet_fixarity(argc, 1); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); const char *err = janet_parser_error(p); if (err) { return (p->flag & JANET_PARSER_GENERATED_ERROR) ? janet_wrap_string((const uint8_t *) err) : janet_cstringv(err); } return janet_wrap_nil(); } JANET_CORE_FN(cfun_parse_produce, "(parser/produce parser &opt wrap)", "Dequeue the next value in the parse queue. Will return nil if " "no parsed values are in the queue, otherwise will dequeue the " "next value. If `wrap` is truthy, will return a 1-element tuple that " "wraps the result. This tuple can be used for source-mapping " "purposes.") { janet_arity(argc, 1, 2); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); if (argc == 2 && janet_truthy(argv[1])) { return janet_parser_produce_wrapped(p); } else { return janet_parser_produce(p); } } JANET_CORE_FN(cfun_parse_flush, "(parser/flush parser)", "Clears the parser state and parse queue. Can be used to reset the parser " "if an error was encountered. Does not reset the line and column counter, so " "to begin parsing in a new context, create a new parser.") { janet_fixarity(argc, 1); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); janet_parser_flush(p); return argv[0]; } JANET_CORE_FN(cfun_parse_where, "(parser/where parser &opt line col)", "Returns the current line number and column of the parser's internal state. If line is " "provided, the current line number of the parser is first set to that value. If column is " "also provided, the current column number of the parser is also first set to that value.") { janet_arity(argc, 1, 3); JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); if (argc > 1) { int32_t line = janet_getinteger(argv, 1); if (line < 1) janet_panicf("invalid line number %d", line); p->line = (size_t) line; } if (argc > 2) { int32_t column = janet_getinteger(argv, 2); if (column < 0) janet_panicf("invalid column number %d", column); p->column = (size_t) column; } Janet *tup = janet_tuple_begin(2); tup[0] = janet_wrap_integer(p->line); tup[1] = janet_wrap_integer(p->column); return janet_wrap_tuple(janet_tuple_end(tup)); } static Janet janet_wrap_parse_state(JanetParseState *s, Janet *args, uint8_t *buff, uint32_t bufcount) { JanetTable *state = janet_table(0); const uint8_t *buffer; int add_buffer = 0; const char *type = NULL; if (s->flags & PFLAG_CONTAINER) { JanetArray *container_args = janet_array(s->argn); for (int32_t i = 0; i < s->argn; i++) { janet_array_push(container_args, args[i]); } janet_table_put(state, janet_ckeywordv("args"), janet_wrap_array(container_args)); } if (s->flags & PFLAG_PARENS || s->flags & PFLAG_SQRBRACKETS) { if (s->flags & PFLAG_ATSYM) { type = "array"; } else { type = "tuple"; } } else if (s->flags & PFLAG_CURLYBRACKETS) { if (s->flags & PFLAG_ATSYM) { type = "table"; } else { type = "struct"; } } else if (s->flags & PFLAG_STRING || s->flags & PFLAG_LONGSTRING) { if (s->flags & PFLAG_BUFFER) { type = "buffer"; } else { type = "string"; } add_buffer = 1; } else if (s->flags & PFLAG_COMMENT) { type = "comment"; add_buffer = 1; } else if (s->flags & PFLAG_TOKEN) { type = "token"; add_buffer = 1; } else if (s->flags & PFLAG_ATSYM) { type = "at"; } else if (s->flags & PFLAG_READERMAC) { int c = s->flags & 0xFF; type = (c == '\'') ? "quote" : (c == ',') ? "unquote" : (c == ';') ? "splice" : (c == '~') ? "quasiquote" : ""; } else { type = "root"; } if (type) { janet_table_put(state, janet_ckeywordv("type"), janet_ckeywordv(type)); } if (add_buffer) { buffer = janet_string(buff, bufcount); janet_table_put(state, janet_ckeywordv("buffer"), janet_wrap_string(buffer)); } janet_table_put(state, janet_ckeywordv("line"), janet_wrap_integer(s->line)); janet_table_put(state, janet_ckeywordv("column"), janet_wrap_integer(s->column)); return janet_wrap_table(state); } struct ParserStateGetter { const char *name; Janet(*fn)(const JanetParser *p); }; static Janet parser_state_delimiters(const JanetParser *_p) { JanetParser *p = (JanetParser *)_p; size_t i; const uint8_t *str; size_t oldcount; oldcount = p->bufcount; for (i = 0; i < p->statecount; i++) { JanetParseState *s = p->states + i; if (s->flags & PFLAG_PARENS) { push_buf(p, '('); } else if (s->flags & PFLAG_SQRBRACKETS) { push_buf(p, '['); } else if (s->flags & PFLAG_CURLYBRACKETS) { push_buf(p, '{'); } else if (s->flags & PFLAG_STRING) { push_buf(p, '"'); } else if (s->flags & PFLAG_LONGSTRING) { int32_t i; for (i = 0; i < s->argn; i++) { push_buf(p, '`'); } } } /* avoid ptr arithmetic on NULL */ str = janet_string(oldcount ? p->buf + oldcount : p->buf, (int32_t)(p->bufcount - oldcount)); p->bufcount = oldcount; return janet_wrap_string(str); } static Janet parser_state_frames(const JanetParser *p) { int32_t count = (int32_t) p->statecount; JanetArray *states = janet_array(count); states->count = count; uint8_t *buf = p->buf; /* Iterate arg stack backwards */ Janet *args = p->argcount ? p->args + p->argcount : p->args; /* avoid ptr arithmetic on NULL */ for (int32_t i = count - 1; i >= 0; --i) { JanetParseState *s = p->states + i; /* avoid ptr arithmetic on args if NULL */ if ((s->flags & PFLAG_CONTAINER) && s->argn) { args -= s->argn; } states->data[i] = janet_wrap_parse_state(s, args, buf, (uint32_t) p->bufcount); } return janet_wrap_array(states); } static const struct ParserStateGetter parser_state_getters[] = { {"frames", parser_state_frames}, {"delimiters", parser_state_delimiters}, {NULL, NULL} }; JANET_CORE_FN(cfun_parse_state, "(parser/state parser &opt key)", "Returns a representation of the internal state of the parser. If a key is passed, " "only that information about the state is returned. Allowed keys are:\n\n" "* :delimiters - Each byte in the string represents a nested data structure. For example, " "if the parser state is '([\"', then the parser is in the middle of parsing a " "string inside of square brackets inside parentheses. Can be used to augment a REPL prompt.\n\n" "* :frames - Each table in the array represents a 'frame' in the parser state. Frames " "contain information about the start of the expression being parsed as well as the " "type of that expression and some type-specific information.") { janet_arity(argc, 1, 2); const uint8_t *key = NULL; JanetParser *p = janet_getabstract(argv, 0, &janet_parser_type); if (argc == 2) { key = janet_getkeyword(argv, 1); } if (key) { /* Get one result */ for (const struct ParserStateGetter *sg = parser_state_getters; sg->name != NULL; sg++) { if (janet_cstrcmp(key, sg->name)) continue; return sg->fn(p); } janet_panicf("unexpected keyword %v", janet_wrap_keyword(key)); return janet_wrap_nil(); } else { /* Put results in table */ JanetTable *tab = janet_table(0); for (const struct ParserStateGetter *sg = parser_state_getters; sg->name != NULL; sg++) { janet_table_put(tab, janet_ckeywordv(sg->name), sg->fn(p)); } return janet_wrap_table(tab); } } JANET_CORE_FN(cfun_parse_clone, "(parser/clone p)", "Creates a deep clone of a parser that is identical to the input parser. " "This cloned parser can be used to continue parsing from a good checkpoint " "if parsing later fails. Returns a new parser.") { janet_fixarity(argc, 1); JanetParser *src = janet_getabstract(argv, 0, &janet_parser_type); JanetParser *dest = janet_abstract(&janet_parser_type, sizeof(JanetParser)); janet_parser_clone(src, dest); return janet_wrap_abstract(dest); } static const JanetMethod parser_methods[] = { {"byte", cfun_parse_byte}, {"clone", cfun_parse_clone}, {"consume", cfun_parse_consume}, {"eof", cfun_parse_eof}, {"error", cfun_parse_error}, {"flush", cfun_parse_flush}, {"has-more", cfun_parse_has_more}, {"insert", cfun_parse_insert}, {"produce", cfun_parse_produce}, {"state", cfun_parse_state}, {"status", cfun_parse_status}, {"where", cfun_parse_where}, {NULL, NULL} }; static int parserget(void *p, Janet key, Janet *out) { (void) p; if (!janet_checktype(key, JANET_KEYWORD)) return 0; return janet_getmethod(janet_unwrap_keyword(key), parser_methods, out); } static Janet parsernext(void *p, Janet key) { (void) p; return janet_nextmethod(parser_methods, key); } /* Load the library */ void janet_lib_parse(JanetTable *env) { JanetRegExt parse_cfuns[] = { JANET_CORE_REG("parser/new", cfun_parse_parser), JANET_CORE_REG("parser/clone", cfun_parse_clone), JANET_CORE_REG("parser/has-more", cfun_parse_has_more), JANET_CORE_REG("parser/produce", cfun_parse_produce), JANET_CORE_REG("parser/consume", cfun_parse_consume), JANET_CORE_REG("parser/byte", cfun_parse_byte), JANET_CORE_REG("parser/error", cfun_parse_error), JANET_CORE_REG("parser/status", cfun_parse_status), JANET_CORE_REG("parser/flush", cfun_parse_flush), JANET_CORE_REG("parser/state", cfun_parse_state), JANET_CORE_REG("parser/where", cfun_parse_where), JANET_CORE_REG("parser/eof", cfun_parse_eof), JANET_CORE_REG("parser/insert", cfun_parse_insert), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, parse_cfuns); } janet-1.41.2/src/core/peg.c000066400000000000000000002146271514534607600153650ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include #include "util.h" #include "vector.h" #include "util.h" #endif #ifdef JANET_PEG /* * Runtime */ /* Hold captured patterns and match state */ typedef struct { const uint8_t *text_start; const uint8_t *text_end; /* text_end can be restricted by some rules, but outer_text_end will always contain the real end of input, which we need to generate a line mapping */ const uint8_t *outer_text_end; const uint32_t *bytecode; const Janet *constants; JanetArray *captures; JanetBuffer *scratch; JanetBuffer *tags; JanetArray *tagged_captures; const Janet *extrav; int32_t *linemap; int32_t extrac; int32_t depth; int32_t linemaplen; int32_t has_backref; enum { PEG_MODE_NORMAL, PEG_MODE_ACCUMULATE } mode; } PegState; /* Allow backtrack with captures. We need * to save state at branches, and then reload * if one branch fails and try a new branch. */ typedef struct { int32_t cap; int32_t tcap; int32_t scratch; } CapState; /* Save the current capture state */ static CapState cap_save(PegState *s) { CapState cs; cs.scratch = s->scratch->count; cs.cap = s->captures->count; cs.tcap = s->tagged_captures->count; return cs; } /* Load a saved capture state in the case of failure */ static void cap_load(PegState *s, CapState cs) { s->scratch->count = cs.scratch; s->captures->count = cs.cap; s->tags->count = cs.tcap; s->tagged_captures->count = cs.tcap; } /* Load a saved capture state in the case of success. Keeps * tagged captures around for backref. */ static void cap_load_keept(PegState *s, CapState cs) { s->scratch->count = cs.scratch; s->captures->count = cs.cap; } /* Add a capture */ static void pushcap(PegState *s, Janet capture, uint32_t tag) { if (s->mode == PEG_MODE_ACCUMULATE) { janet_to_string_b(s->scratch, capture); } if (s->mode == PEG_MODE_NORMAL) { janet_array_push(s->captures, capture); } if (s->has_backref) { janet_array_push(s->tagged_captures, capture); janet_buffer_push_u8(s->tags, tag); } } /* Lazily generate line map to get line and column information for PegState. * line and column are 1-indexed. */ typedef struct { int32_t line; int32_t col; } LineCol; static LineCol get_linecol_from_position(PegState *s, int32_t position) { /* Generate if not made yet */ if (s->linemaplen < 0) { int32_t newline_count = 0; for (const uint8_t *c = s->text_start; c < s->outer_text_end; c++) { if (*c == '\n') newline_count++; } int32_t *mem = janet_smalloc(sizeof(int32_t) * newline_count); size_t index = 0; for (const uint8_t *c = s->text_start; c < s->outer_text_end; c++) { if (*c == '\n') mem[index++] = (int32_t)(c - s->text_start); } s->linemaplen = newline_count; s->linemap = mem; } /* Do binary search for line. Slightly modified from classic binary search: * - if we find that our current character is a line break, just return immediately. * a newline character is consider to be on the same line as the character before * (\n is line terminator, not line separator). * - in the not-found case, we still want to find the greatest-indexed newline that * is before position. we use that to calculate the line and column. * - in the case that lo = 0 and s->linemap[0] is still greater than position, we * are on the first line and our column is position + 1. */ int32_t hi = s->linemaplen; /* hi is greater than the actual line */ int32_t lo = 0; /* lo is less than or equal to the actual line */ LineCol ret; while (lo + 1 < hi) { int32_t mid = lo + (hi - lo) / 2; if (s->linemap[mid] >= position) { hi = mid; } else { lo = mid; } } /* first line case */ if (s->linemaplen == 0 || (lo == 0 && s->linemap[0] >= position)) { ret.line = 1; ret.col = position + 1; } else { ret.line = lo + 2; ret.col = position - s->linemap[lo]; } return ret; } /* Convert a uint64_t to a int64_t by wrapping to a maximum number of bytes */ static int64_t peg_convert_u64_s64(uint64_t from, int width) { int shift = 8 * (8 - width); return ((int64_t)(from << shift)) >> shift; } /* Prevent stack overflow */ #define down1(s) do { \ if (0 == --((s)->depth)) janet_panic("peg/match recursed too deeply"); \ } while (0) #define up1(s) ((s)->depth++) /* Evaluate a peg rule * Pre-conditions: s is in a valid state * Post-conditions: If there is a match, returns a pointer to the next text. * All captures on the capture stack are valid. If there is no match, * returns NULL. Extra captures from successful child expressions can be * left on the capture stack. */ static const uint8_t *peg_rule( PegState *s, const uint32_t *rule, const uint8_t *text) { tail: switch (*rule) { default: janet_panic("unexpected opcode"); return NULL; case RULE_LITERAL: { uint32_t len = rule[1]; if (text + len > s->text_end) return NULL; return memcmp(text, rule + 2, len) ? NULL : text + len; } case RULE_DEBUG: { char buffer[32] = {0}; size_t len = (size_t)(s->outer_text_end - text); memcpy(buffer, text, (len > 31 ? 31 : len)); janet_eprintf("?? at [%s] (index %d)\n", buffer, (int32_t)(text - s->text_start)); int has_color = janet_truthy(janet_dyn("err-color")); /* Accumulate buffer */ if (s->scratch->count) { janet_eprintf("accumulate buffer: %v\n", janet_wrap_buffer(s->scratch)); } /* Normal captures */ if (s->captures->count) { janet_eprintf("stack [%d]:\n", s->captures->count); for (int32_t i = 0; i < s->captures->count; i++) { if (has_color) { janet_eprintf(" [%d]: %M\n", i, s->captures->data[i]); } else { janet_eprintf(" [%d]: %m\n", i, s->captures->data[i]); } } } /* Tagged captures */ if (s->tagged_captures->count) { janet_eprintf("tag stack [%d]:\n", s->tagged_captures->count); for (int32_t i = 0; i < s->tagged_captures->count; i++) { if (has_color) { janet_eprintf(" [%d] tag=%d: %M\n", i, (int32_t) s->tags->data[i], s->tagged_captures->data[i]); } else { janet_eprintf(" [%d] tag=%d: %m\n", i, (int32_t) s->tags->data[i], s->tagged_captures->data[i]); } } } return text; } case RULE_NCHAR: { uint32_t n = rule[1]; return (text + n > s->text_end) ? NULL : text + n; } case RULE_NOTNCHAR: { uint32_t n = rule[1]; return (text + n > s->text_end) ? text : NULL; } case RULE_RANGE: { uint8_t lo = rule[1] & 0xFF; uint8_t hi = (rule[1] >> 16) & 0xFF; return (text < s->text_end && text[0] >= lo && text[0] <= hi) ? text + 1 : NULL; } case RULE_SET: { if (text >= s->text_end) return NULL; uint32_t word = rule[1 + (text[0] >> 5)]; uint32_t mask = (uint32_t)1 << (text[0] & 0x1F); return (word & mask) ? text + 1 : NULL; } case RULE_LOOK: { text += ((int32_t *)rule)[1]; if (text < s->text_start || text > s->text_end) return NULL; down1(s); const uint8_t *result = peg_rule(s, s->bytecode + rule[2], text); up1(s); text -= ((int32_t *)rule)[1]; return result ? text : NULL; } case RULE_CHOICE: { uint32_t len = rule[1]; const uint32_t *args = rule + 2; if (len == 0) return NULL; down1(s); CapState cs = cap_save(s); for (uint32_t i = 0; i < len - 1; i++) { const uint8_t *result = peg_rule(s, s->bytecode + args[i], text); if (result) { up1(s); return result; } cap_load(s, cs); } up1(s); rule = s->bytecode + args[len - 1]; goto tail; } case RULE_SEQUENCE: { uint32_t len = rule[1]; const uint32_t *args = rule + 2; if (len == 0) return text; down1(s); for (uint32_t i = 0; text && i < len - 1; i++) text = peg_rule(s, s->bytecode + args[i], text); up1(s); if (!text) return NULL; rule = s->bytecode + args[len - 1]; goto tail; } case RULE_IF: { const uint32_t *rule_a = s->bytecode + rule[1]; const uint32_t *rule_b = s->bytecode + rule[2]; down1(s); const uint8_t *result = peg_rule(s, rule_a, text); up1(s); if (!result) return NULL; rule = rule_b; goto tail; } case RULE_IFNOT: { const uint32_t *rule_a = s->bytecode + rule[1]; const uint32_t *rule_b = s->bytecode + rule[2]; down1(s); CapState cs = cap_save(s); const uint8_t *result = peg_rule(s, rule_a, text); if (!!result) { up1(s); return NULL; } else { cap_load(s, cs); up1(s); rule = rule_b; goto tail; } } case RULE_NOT: { const uint32_t *rule_a = s->bytecode + rule[1]; down1(s); CapState cs = cap_save(s); const uint8_t *result = peg_rule(s, rule_a, text); if (result) { up1(s); return NULL; } else { cap_load(s, cs); up1(s); return text; } } case RULE_THRU: case RULE_TO: { const uint32_t *rule_a = s->bytecode + rule[1]; const uint8_t *next_text = NULL; CapState cs = cap_save(s); down1(s); while (text <= s->text_end) { CapState cs2 = cap_save(s); next_text = peg_rule(s, rule_a, text); if (next_text) { if (rule[0] == RULE_TO) cap_load(s, cs2); break; } cap_load(s, cs2); text++; } up1(s); if (text > s->text_end) { cap_load(s, cs); return NULL; } return rule[0] == RULE_TO ? text : next_text; } case RULE_BETWEEN: { uint32_t lo = rule[1]; uint32_t hi = rule[2]; const uint32_t *rule_a = s->bytecode + rule[3]; uint32_t captured = 0; const uint8_t *next_text; CapState cs = cap_save(s); down1(s); while (captured < hi) { CapState cs2 = cap_save(s); next_text = peg_rule(s, rule_a, text); if (!next_text || ((next_text == text) && (hi == UINT32_MAX))) { cap_load(s, cs2); break; } captured++; text = next_text; } up1(s); if (captured < lo) { cap_load(s, cs); return NULL; } return text; } /* Capturing rules */ case RULE_GETTAG: { uint32_t search = rule[1]; uint32_t tag = rule[2]; for (int32_t i = s->tags->count - 1; i >= 0; i--) { if (s->tags->data[i] == search) { pushcap(s, s->tagged_captures->data[i], tag); return text; } } return NULL; } case RULE_POSITION: { pushcap(s, janet_wrap_number((double)(text - s->text_start)), rule[1]); return text; } case RULE_LINE: { LineCol lc = get_linecol_from_position(s, (int32_t)(text - s->text_start)); pushcap(s, janet_wrap_number((double)(lc.line)), rule[1]); return text; } case RULE_COLUMN: { LineCol lc = get_linecol_from_position(s, (int32_t)(text - s->text_start)); pushcap(s, janet_wrap_number((double)(lc.col)), rule[1]); return text; } case RULE_ARGUMENT: { int32_t index = ((int32_t *)rule)[1]; Janet capture = (index >= s->extrac) ? janet_wrap_nil() : s->extrav[index]; pushcap(s, capture, rule[2]); return text; } case RULE_CONSTANT: { pushcap(s, s->constants[rule[1]], rule[2]); return text; } case RULE_CAPTURE: { down1(s); const uint8_t *result = peg_rule(s, s->bytecode + rule[1], text); up1(s); if (!result) return NULL; /* Specialized pushcap - avoid intermediate string creation */ if (!s->has_backref && s->mode == PEG_MODE_ACCUMULATE) { janet_buffer_push_bytes(s->scratch, text, (int32_t)(result - text)); } else { uint32_t tag = rule[2]; pushcap(s, janet_stringv(text, (int32_t)(result - text)), tag); } return result; } case RULE_CAPTURE_NUM: { down1(s); const uint8_t *result = peg_rule(s, s->bytecode + rule[1], text); up1(s); if (!result) return NULL; /* check number parsing */ double x = 0.0; int32_t base = (int32_t) rule[2]; if (janet_scan_number_base(text, (int32_t)(result - text), base, &x)) return NULL; /* Specialized pushcap - avoid intermediate string creation */ if (!s->has_backref && s->mode == PEG_MODE_ACCUMULATE) { janet_buffer_push_bytes(s->scratch, text, (int32_t)(result - text)); } else { uint32_t tag = rule[3]; pushcap(s, janet_wrap_number(x), tag); } return result; } case RULE_ACCUMULATE: { uint32_t tag = rule[2]; int oldmode = s->mode; if (!tag && oldmode == PEG_MODE_ACCUMULATE) { rule = s->bytecode + rule[1]; goto tail; } CapState cs = cap_save(s); s->mode = PEG_MODE_ACCUMULATE; down1(s); const uint8_t *result = peg_rule(s, s->bytecode + rule[1], text); up1(s); s->mode = oldmode; if (!result) return NULL; Janet cap = janet_stringv(s->scratch->data + cs.scratch, s->scratch->count - cs.scratch); cap_load_keept(s, cs); pushcap(s, cap, tag); return result; } case RULE_DROP: { CapState cs = cap_save(s); down1(s); const uint8_t *result = peg_rule(s, s->bytecode + rule[1], text); up1(s); if (!result) return NULL; cap_load(s, cs); return result; } case RULE_ONLY_TAGS: { CapState cs = cap_save(s); down1(s); const uint8_t *result = peg_rule(s, s->bytecode + rule[1], text); up1(s); if (!result) return NULL; cap_load_keept(s, cs); return result; } case RULE_GROUP: { uint32_t tag = rule[2]; int oldmode = s->mode; CapState cs = cap_save(s); s->mode = PEG_MODE_NORMAL; down1(s); const uint8_t *result = peg_rule(s, s->bytecode + rule[1], text); up1(s); s->mode = oldmode; if (!result) return NULL; int32_t num_sub_captures = s->captures->count - cs.cap; JanetArray *sub_captures = janet_array(num_sub_captures); safe_memcpy(sub_captures->data, s->captures->data + cs.cap, sizeof(Janet) * num_sub_captures); sub_captures->count = num_sub_captures; cap_load_keept(s, cs); pushcap(s, janet_wrap_array(sub_captures), tag); return result; } case RULE_NTH: { uint32_t nth = rule[1]; if (nth > INT32_MAX) nth = INT32_MAX; uint32_t tag = rule[3]; int oldmode = s->mode; CapState cs = cap_save(s); s->mode = PEG_MODE_NORMAL; down1(s); const uint8_t *result = peg_rule(s, s->bytecode + rule[2], text); up1(s); s->mode = oldmode; if (!result) return NULL; int32_t num_sub_captures = s->captures->count - cs.cap; Janet cap; if (num_sub_captures > (int32_t) nth) { cap = s->captures->data[cs.cap + nth]; } else { return NULL; } cap_load_keept(s, cs); pushcap(s, cap, tag); return result; } case RULE_SUB: { const uint8_t *text_start = text; const uint32_t *rule_window = s->bytecode + rule[1]; const uint32_t *rule_subpattern = s->bytecode + rule[2]; down1(s); const uint8_t *window_end = peg_rule(s, rule_window, text); up1(s); if (!window_end) { return NULL; } const uint8_t *saved_end = s->text_end; s->text_end = window_end; down1(s); const uint8_t *next_text = peg_rule(s, rule_subpattern, text_start); up1(s); s->text_end = saved_end; if (!next_text) { return NULL; } return window_end; } case RULE_TIL: { const uint32_t *rule_terminus = s->bytecode + rule[1]; const uint32_t *rule_subpattern = s->bytecode + rule[2]; const uint8_t *terminus_start = text; const uint8_t *terminus_end = NULL; down1(s); while (terminus_start <= s->text_end) { CapState cs2 = cap_save(s); terminus_end = peg_rule(s, rule_terminus, terminus_start); cap_load(s, cs2); if (terminus_end) { break; } terminus_start++; } up1(s); if (!terminus_end) { return NULL; } const uint8_t *saved_end = s->text_end; s->text_end = terminus_start; down1(s); const uint8_t *matched = peg_rule(s, rule_subpattern, text); up1(s); s->text_end = saved_end; if (!matched) { return NULL; } return terminus_end; } case RULE_SPLIT: { const uint8_t *saved_end = s->text_end; const uint32_t *rule_separator = s->bytecode + rule[1]; const uint32_t *rule_subpattern = s->bytecode + rule[2]; const uint8_t *chunk_start = text; const uint8_t *chunk_end = NULL; while (text <= saved_end) { /* Find next split (or end of text) */ CapState cs = cap_save(s); down1(s); while (text <= saved_end) { chunk_end = text; const uint8_t *check = peg_rule(s, rule_separator, text); cap_load(s, cs); if (check) { text = check; break; } text++; } up1(s); /* Match between splits */ s->text_end = chunk_end; down1(s); const uint8_t *subpattern_end = peg_rule(s, rule_subpattern, chunk_start); up1(s); s->text_end = saved_end; if (!subpattern_end) return NULL; /* Don't match anything */ /* Ensure forward progress */ if (text == chunk_start) return NULL; chunk_start = text; } s->text_end = saved_end; return s->text_end; } case RULE_REPLACE: case RULE_MATCHSPLICE: case RULE_MATCHTIME: { uint32_t tag = rule[3]; int oldmode = s->mode; CapState cs = cap_save(s); s->mode = PEG_MODE_NORMAL; down1(s); const uint8_t *result = peg_rule(s, s->bytecode + rule[1], text); up1(s); s->mode = oldmode; if (!result) return NULL; Janet cap = janet_wrap_nil(); Janet constant = s->constants[rule[2]]; switch (janet_type(constant)) { default: cap = constant; break; case JANET_STRUCT: if (s->captures->count) { cap = janet_struct_get(janet_unwrap_struct(constant), s->captures->data[s->captures->count - 1]); } break; case JANET_TABLE: if (s->captures->count) { cap = janet_table_get(janet_unwrap_table(constant), s->captures->data[s->captures->count - 1]); } break; case JANET_CFUNCTION: cap = janet_unwrap_cfunction(constant)(s->captures->count - cs.cap, s->captures->data + cs.cap); break; case JANET_FUNCTION: cap = janet_call(janet_unwrap_function(constant), s->captures->count - cs.cap, s->captures->data + cs.cap); break; } cap_load_keept(s, cs); if (rule[0] != RULE_REPLACE && !janet_truthy(cap)) return NULL; /* matchtime or matchtime flatten */ const Janet *elements = NULL; int32_t len = 0; if ((rule[0] == RULE_MATCHSPLICE) && janet_indexed_view(cap, &elements, &len)) { /* unpack and flatten capture */ for (int32_t i = 0; i < len; i++) { pushcap(s, elements[i], tag); } } else { pushcap(s, cap, tag); } return result; } case RULE_ERROR: { int oldmode = s->mode; s->mode = PEG_MODE_NORMAL; int32_t old_cap = s->captures->count; down1(s); const uint8_t *result = peg_rule(s, s->bytecode + rule[1], text); up1(s); s->mode = oldmode; if (!result) return NULL; if (s->captures->count > old_cap) { /* Throw last capture */ janet_panicv(s->captures->data[s->captures->count - 1]); } else { /* Throw generic error */ int32_t start = (int32_t)(text - s->text_start); LineCol lc = get_linecol_from_position(s, start); janet_panicf("match error at line %d, column %d", lc.line, lc.col); } return NULL; } case RULE_BACKMATCH: { uint32_t search = rule[1]; for (int32_t i = s->tags->count - 1; i >= 0; i--) { if (s->tags->data[i] == search) { Janet capture = s->tagged_captures->data[i]; if (!janet_checktype(capture, JANET_STRING)) return NULL; const uint8_t *bytes = janet_unwrap_string(capture); int32_t len = janet_string_length(bytes); if (text + len > s->text_end) return NULL; return memcmp(text, bytes, len) ? NULL : text + len; } } return NULL; } case RULE_LENPREFIX: { int oldmode = s->mode; s->mode = PEG_MODE_NORMAL; const uint8_t *next_text; CapState cs = cap_save(s); down1(s); next_text = peg_rule(s, s->bytecode + rule[1], text); up1(s); if (NULL == next_text) return NULL; s->mode = oldmode; int32_t num_sub_captures = s->captures->count - cs.cap; Janet lencap; if (num_sub_captures <= 0 || (lencap = s->captures->data[cs.cap], !janet_checkint(lencap))) { cap_load(s, cs); return NULL; } int32_t nrep = janet_unwrap_integer(lencap); /* drop captures from len pattern */ cap_load(s, cs); for (int32_t i = 0; i < nrep; i++) { down1(s); next_text = peg_rule(s, s->bytecode + rule[2], next_text); up1(s); if (NULL == next_text) { cap_load(s, cs); return NULL; } } return next_text; } case RULE_READINT: { uint32_t tag = rule[2]; uint32_t signedness = rule[1] & 0x10; uint32_t endianness = rule[1] & 0x20; int width = (int)(rule[1] & 0xF); if (text + width > s->text_end) return NULL; uint64_t accum = 0; if (endianness) { /* BE */ for (int i = 0; i < width; i++) accum = (accum << 8) | text[i]; } else { /* LE */ for (int i = width - 1; i >= 0; i--) accum = (accum << 8) | text[i]; } Janet capture_value; /* We can only parse integeres of greater than 6 bytes reliable if int-types are enabled. * Otherwise, we may lose precision, so 6 is the maximum size when int-types are disabled. */ #ifdef JANET_INT_TYPES if (width > 6) { if (signedness) { capture_value = janet_wrap_s64(peg_convert_u64_s64(accum, width)); } else { capture_value = janet_wrap_u64(accum); } } else #endif { double double_value; if (signedness) { double_value = (double)(peg_convert_u64_s64(accum, width)); } else { double_value = (double)accum; } capture_value = janet_wrap_number(double_value); } pushcap(s, capture_value, tag); return text + width; } case RULE_UNREF: { int32_t tcap = s->tags->count; down1(s); const uint8_t *result = peg_rule(s, s->bytecode + rule[1], text); up1(s); if (!result) return NULL; int32_t final_tcap = s->tags->count; /* Truncate tagged captures to not include items of the given tag */ int32_t w = tcap; /* If no tag is given, drop ALL tagged captures */ if (rule[2]) { for (int32_t i = tcap; i < final_tcap; i++) { if (s->tags->data[i] != (0xFF & rule[2])) { s->tags->data[w] = s->tags->data[i]; s->tagged_captures->data[w] = s->tagged_captures->data[i]; w++; } } } s->tags->count = w; s->tagged_captures->count = w; return result; } } } /* * Compilation */ typedef struct { JanetTable *grammar; JanetTable *default_grammar; JanetTable *tags; Janet *constants; uint32_t *bytecode; Janet form; int depth; uint32_t nexttag; int has_backref; } Builder; /* Forward declaration to allow recursion */ static uint32_t peg_compile1(Builder *b, Janet peg); /* * Errors */ static void builder_cleanup(Builder *b) { janet_v_free(b->constants); janet_v_free(b->bytecode); } JANET_NO_RETURN static void peg_panic(Builder *b, const char *msg) { builder_cleanup(b); janet_panicf("grammar error in %p, %s", b->form, msg); } #define peg_panicf(b,...) peg_panic((b), (const char *) janet_formatc(__VA_ARGS__)) static void peg_fixarity(Builder *b, int32_t argc, int32_t arity) { if (argc != arity) { peg_panicf(b, "expected %d argument%s, got %d", arity, arity == 1 ? "" : "s", argc); } } static void peg_arity(Builder *b, int32_t arity, int32_t min, int32_t max) { if (min >= 0 && arity < min) peg_panicf(b, "arity mismatch, expected at least %d, got %d", min, arity); if (max >= 0 && arity > max) peg_panicf(b, "arity mismatch, expected at most %d, got %d", max, arity); } static const uint8_t *peg_getset(Builder *b, Janet x) { if (!janet_checktype(x, JANET_STRING)) peg_panic(b, "expected string for character set"); const uint8_t *str = janet_unwrap_string(x); return str; } static const uint8_t *peg_getrange(Builder *b, Janet x) { if (!janet_checktype(x, JANET_STRING)) peg_panic(b, "expected string for character range"); const uint8_t *str = janet_unwrap_string(x); if (janet_string_length(str) != 2) peg_panicf(b, "expected string to have length 2, got %v", x); if (str[1] < str[0]) peg_panicf(b, "range %v is empty", x); return str; } static int32_t peg_getinteger(Builder *b, Janet x) { if (!janet_checkint(x)) peg_panicf(b, "expected integer, got %v", x); return janet_unwrap_integer(x); } static int32_t peg_getnat(Builder *b, Janet x) { int32_t i = peg_getinteger(b, x); if (i < 0) peg_panicf(b, "expected non-negative integer, got %v", x); return i; } /* * Emission */ static uint32_t emit_constant(Builder *b, Janet c) { uint32_t cindex = (uint32_t) janet_v_count(b->constants); janet_v_push(b->constants, c); return cindex; } static uint32_t emit_tag(Builder *b, Janet t) { if (!janet_checktype(t, JANET_KEYWORD)) peg_panicf(b, "expected keyword for capture tag, got %v", t); Janet check = janet_table_get(b->tags, t); if (janet_checktype(check, JANET_NIL)) { uint32_t tag = b->nexttag++; if (tag > 255) { peg_panic(b, "too many tags - up to 255 tags are supported per peg"); } Janet val = janet_wrap_number(tag); janet_table_put(b->tags, t, val); return tag; } else { return (uint32_t) janet_unwrap_number(check); } } /* Reserve space in bytecode for a rule. When a special emits a rule, * it must place that rule immediately on the bytecode stack. This lets * the compiler know where the rule is going to be before it is complete, * allowing recursive rules. */ typedef struct { Builder *builder; uint32_t index; int32_t size; } Reserve; static Reserve reserve(Builder *b, int32_t size) { Reserve r; r.index = janet_v_count(b->bytecode); r.builder = b; r.size = size; for (int32_t i = 0; i < size; i++) janet_v_push(b->bytecode, 0); return r; } /* Emit a rule in the builder. Returns the index of the new rule */ static void emit_rule(Reserve r, int32_t op, int32_t n, const uint32_t *body) { janet_assert(r.size == n + 1, "bad reserve"); r.builder->bytecode[r.index] = op; memcpy(r.builder->bytecode + r.index + 1, body, n * sizeof(uint32_t)); } /* For RULE_LITERAL */ static void emit_bytes(Builder *b, uint32_t op, int32_t len, const uint8_t *bytes) { uint32_t next_rule = janet_v_count(b->bytecode); janet_v_push(b->bytecode, op); janet_v_push(b->bytecode, len); int32_t words = ((len + 3) >> 2); for (int32_t i = 0; i < words; i++) janet_v_push(b->bytecode, 0); memcpy(b->bytecode + next_rule + 2, bytes, len); } /* For fixed arity rules of arities 1, 2, and 3 */ static void emit_1(Reserve r, uint32_t op, uint32_t arg) { emit_rule(r, op, 1, &arg); } static void emit_2(Reserve r, uint32_t op, uint32_t arg1, uint32_t arg2) { uint32_t arr[2] = {arg1, arg2}; emit_rule(r, op, 2, arr); } static void emit_3(Reserve r, uint32_t op, uint32_t arg1, uint32_t arg2, uint32_t arg3) { uint32_t arr[3] = {arg1, arg2, arg3}; emit_rule(r, op, 3, arr); } /* * Specials */ static void bitmap_set(uint32_t *bitmap, uint8_t c) { bitmap[c >> 5] |= ((uint32_t)1) << (c & 0x1F); } static void spec_range(Builder *b, int32_t argc, const Janet *argv) { peg_arity(b, argc, 1, -1); if (argc == 1) { Reserve r = reserve(b, 2); const uint8_t *str = peg_getrange(b, argv[0]); uint32_t arg = str[0] | (str[1] << 16); emit_1(r, RULE_RANGE, arg); } else { /* Compile as a set */ Reserve r = reserve(b, 9); uint32_t bitmap[8] = {0}; for (int32_t i = 0; i < argc; i++) { const uint8_t *str = peg_getrange(b, argv[i]); for (uint32_t c = str[0]; c <= str[1]; c++) bitmap_set(bitmap, c); } emit_rule(r, RULE_SET, 8, bitmap); } } static void spec_set(Builder *b, int32_t argc, const Janet *argv) { peg_fixarity(b, argc, 1); Reserve r = reserve(b, 9); const uint8_t *str = peg_getset(b, argv[0]); uint32_t bitmap[8] = {0}; for (int32_t i = 0; i < janet_string_length(str); i++) bitmap_set(bitmap, str[i]); emit_rule(r, RULE_SET, 8, bitmap); } static void spec_look(Builder *b, int32_t argc, const Janet *argv) { peg_arity(b, argc, 1, 2); Reserve r = reserve(b, 3); int32_t rulearg = argc == 2 ? 1 : 0; int32_t offset = argc == 2 ? peg_getinteger(b, argv[0]) : 0; uint32_t subrule = peg_compile1(b, argv[rulearg]); emit_2(r, RULE_LOOK, (uint32_t) offset, subrule); } /* Rule of the form [len, rules...] */ static void spec_variadic(Builder *b, int32_t argc, const Janet *argv, uint32_t op) { uint32_t rule = janet_v_count(b->bytecode); janet_v_push(b->bytecode, op); janet_v_push(b->bytecode, argc); for (int32_t i = 0; i < argc; i++) janet_v_push(b->bytecode, 0); for (int32_t i = 0; i < argc; i++) { uint32_t rulei = peg_compile1(b, argv[i]); b->bytecode[rule + 2 + i] = rulei; } } static void spec_choice(Builder *b, int32_t argc, const Janet *argv) { spec_variadic(b, argc, argv, RULE_CHOICE); } static void spec_sequence(Builder *b, int32_t argc, const Janet *argv) { spec_variadic(b, argc, argv, RULE_SEQUENCE); } /* For (if a b) and (if-not a b) */ static void spec_branch(Builder *b, int32_t argc, const Janet *argv, uint32_t rule) { peg_fixarity(b, argc, 2); Reserve r = reserve(b, 3); uint32_t rule_a = peg_compile1(b, argv[0]); uint32_t rule_b = peg_compile1(b, argv[1]); emit_2(r, rule, rule_a, rule_b); } static void spec_if(Builder *b, int32_t argc, const Janet *argv) { spec_branch(b, argc, argv, RULE_IF); } static void spec_ifnot(Builder *b, int32_t argc, const Janet *argv) { spec_branch(b, argc, argv, RULE_IFNOT); } static void spec_lenprefix(Builder *b, int32_t argc, const Janet *argv) { spec_branch(b, argc, argv, RULE_LENPREFIX); } static void spec_between(Builder *b, int32_t argc, const Janet *argv) { peg_fixarity(b, argc, 3); Reserve r = reserve(b, 4); int32_t lo = peg_getnat(b, argv[0]); int32_t hi = peg_getnat(b, argv[1]); uint32_t subrule = peg_compile1(b, argv[2]); emit_3(r, RULE_BETWEEN, lo, hi, subrule); } static void spec_repeater(Builder *b, int32_t argc, const Janet *argv, int32_t min) { peg_fixarity(b, argc, 1); Reserve r = reserve(b, 4); uint32_t subrule = peg_compile1(b, argv[0]); emit_3(r, RULE_BETWEEN, min, UINT32_MAX, subrule); } static void spec_some(Builder *b, int32_t argc, const Janet *argv) { spec_repeater(b, argc, argv, 1); } static void spec_any(Builder *b, int32_t argc, const Janet *argv) { spec_repeater(b, argc, argv, 0); } static void spec_atleast(Builder *b, int32_t argc, const Janet *argv) { peg_fixarity(b, argc, 2); Reserve r = reserve(b, 4); int32_t n = peg_getnat(b, argv[0]); uint32_t subrule = peg_compile1(b, argv[1]); emit_3(r, RULE_BETWEEN, n, UINT32_MAX, subrule); } static void spec_atmost(Builder *b, int32_t argc, const Janet *argv) { peg_fixarity(b, argc, 2); Reserve r = reserve(b, 4); int32_t n = peg_getnat(b, argv[0]); uint32_t subrule = peg_compile1(b, argv[1]); emit_3(r, RULE_BETWEEN, 0, n, subrule); } static void spec_opt(Builder *b, int32_t argc, const Janet *argv) { peg_fixarity(b, argc, 1); Reserve r = reserve(b, 4); uint32_t subrule = peg_compile1(b, argv[0]); emit_3(r, RULE_BETWEEN, 0, 1, subrule); } static void spec_repeat(Builder *b, int32_t argc, const Janet *argv) { peg_fixarity(b, argc, 2); Reserve r = reserve(b, 4); int32_t n = peg_getnat(b, argv[0]); uint32_t subrule = peg_compile1(b, argv[1]); emit_3(r, RULE_BETWEEN, n, n, subrule); } /* Rule of the form [rule] */ static void spec_onerule(Builder *b, int32_t argc, const Janet *argv, uint32_t op) { peg_fixarity(b, argc, 1); Reserve r = reserve(b, 2); uint32_t rule = peg_compile1(b, argv[0]); emit_1(r, op, rule); } static void spec_not(Builder *b, int32_t argc, const Janet *argv) { spec_onerule(b, argc, argv, RULE_NOT); } static void spec_error(Builder *b, int32_t argc, const Janet *argv) { if (argc == 0) { Reserve r = reserve(b, 2); uint32_t rule = peg_compile1(b, janet_wrap_number(0)); emit_1(r, RULE_ERROR, rule); } else { spec_onerule(b, argc, argv, RULE_ERROR); } } static void spec_to(Builder *b, int32_t argc, const Janet *argv) { spec_onerule(b, argc, argv, RULE_TO); } static void spec_thru(Builder *b, int32_t argc, const Janet *argv) { spec_onerule(b, argc, argv, RULE_THRU); } static void spec_drop(Builder *b, int32_t argc, const Janet *argv) { spec_onerule(b, argc, argv, RULE_DROP); } static void spec_only_tags(Builder *b, int32_t argc, const Janet *argv) { spec_onerule(b, argc, argv, RULE_ONLY_TAGS); } /* Rule of the form [rule, tag] */ static void spec_cap1(Builder *b, int32_t argc, const Janet *argv, uint32_t op) { peg_arity(b, argc, 1, 2); Reserve r = reserve(b, 3); uint32_t tag = (argc == 2) ? emit_tag(b, argv[1]) : 0; uint32_t rule = peg_compile1(b, argv[0]); emit_2(r, op, rule, tag); } static void spec_capture(Builder *b, int32_t argc, const Janet *argv) { spec_cap1(b, argc, argv, RULE_CAPTURE); } static void spec_accumulate(Builder *b, int32_t argc, const Janet *argv) { spec_cap1(b, argc, argv, RULE_ACCUMULATE); } static void spec_group(Builder *b, int32_t argc, const Janet *argv) { spec_cap1(b, argc, argv, RULE_GROUP); } static void spec_unref(Builder *b, int32_t argc, const Janet *argv) { spec_cap1(b, argc, argv, RULE_UNREF); } static void spec_nth(Builder *b, int32_t argc, const Janet *argv) { peg_arity(b, argc, 2, 3); Reserve r = reserve(b, 4); uint32_t nth = peg_getnat(b, argv[0]); uint32_t rule = peg_compile1(b, argv[1]); uint32_t tag = (argc == 3) ? emit_tag(b, argv[2]) : 0; emit_3(r, RULE_NTH, nth, rule, tag); } static void spec_capture_number(Builder *b, int32_t argc, const Janet *argv) { peg_arity(b, argc, 1, 3); Reserve r = reserve(b, 4); uint32_t base = 0; if (argc >= 2) { if (!janet_checktype(argv[1], JANET_NIL)) { if (!janet_checkint(argv[1])) goto error; base = (uint32_t) janet_unwrap_integer(argv[1]); if (base < 2 || base > 36) goto error; } } uint32_t tag = (argc == 3) ? emit_tag(b, argv[2]) : 0; uint32_t rule = peg_compile1(b, argv[0]); emit_3(r, RULE_CAPTURE_NUM, rule, base, tag); return; error: peg_panicf(b, "expected integer between 2 and 36, got %v", argv[1]); } static void spec_reference(Builder *b, int32_t argc, const Janet *argv) { peg_arity(b, argc, 1, 2); Reserve r = reserve(b, 3); uint32_t search = emit_tag(b, argv[0]); uint32_t tag = (argc == 2) ? emit_tag(b, argv[1]) : 0; b->has_backref = 1; emit_2(r, RULE_GETTAG, search, tag); } static void spec_tag1(Builder *b, int32_t argc, const Janet *argv, uint32_t op) { peg_arity(b, argc, 0, 1); Reserve r = reserve(b, 2); uint32_t tag = (argc) ? emit_tag(b, argv[0]) : 0; (void) argv; emit_1(r, op, tag); } static void spec_position(Builder *b, int32_t argc, const Janet *argv) { spec_tag1(b, argc, argv, RULE_POSITION); } static void spec_line(Builder *b, int32_t argc, const Janet *argv) { spec_tag1(b, argc, argv, RULE_LINE); } static void spec_column(Builder *b, int32_t argc, const Janet *argv) { spec_tag1(b, argc, argv, RULE_COLUMN); } static void spec_backmatch(Builder *b, int32_t argc, const Janet *argv) { b->has_backref = 1; spec_tag1(b, argc, argv, RULE_BACKMATCH); } static void spec_argument(Builder *b, int32_t argc, const Janet *argv) { peg_arity(b, argc, 1, 2); Reserve r = reserve(b, 3); uint32_t tag = (argc == 2) ? emit_tag(b, argv[1]) : 0; int32_t index = peg_getnat(b, argv[0]); emit_2(r, RULE_ARGUMENT, index, tag); } static void spec_constant(Builder *b, int32_t argc, const Janet *argv) { janet_arity(argc, 1, 2); Reserve r = reserve(b, 3); uint32_t tag = (argc == 2) ? emit_tag(b, argv[1]) : 0; emit_2(r, RULE_CONSTANT, emit_constant(b, argv[0]), tag); } static void spec_debug(Builder *b, int32_t argc, const Janet *argv) { peg_arity(b, argc, 0, 0); Reserve r = reserve(b, 1); uint32_t empty = 0; (void) argv; emit_rule(r, RULE_DEBUG, 0, &empty); } static void spec_replace(Builder *b, int32_t argc, const Janet *argv) { peg_arity(b, argc, 2, 3); Reserve r = reserve(b, 4); uint32_t subrule = peg_compile1(b, argv[0]); uint32_t constant = emit_constant(b, argv[1]); uint32_t tag = (argc == 3) ? emit_tag(b, argv[2]) : 0; emit_3(r, RULE_REPLACE, subrule, constant, tag); } static void spec_matchtime_impl(Builder *b, int32_t argc, const Janet *argv, uint32_t op) { peg_arity(b, argc, 2, 3); Reserve r = reserve(b, 4); uint32_t subrule = peg_compile1(b, argv[0]); Janet fun = argv[1]; if (!janet_checktype(fun, JANET_FUNCTION) && !janet_checktype(fun, JANET_CFUNCTION)) { peg_panicf(b, "expected function or cfunction, got %v", fun); } uint32_t tag = (argc == 3) ? emit_tag(b, argv[2]) : 0; uint32_t cindex = emit_constant(b, fun); emit_3(r, op, subrule, cindex, tag); } static void spec_matchtime(Builder *b, int32_t argc, const Janet *argv) { spec_matchtime_impl(b, argc, argv, RULE_MATCHTIME); } static void spec_matchtime_splice(Builder *b, int32_t argc, const Janet *argv) { spec_matchtime_impl(b, argc, argv, RULE_MATCHSPLICE); } static void spec_sub(Builder *b, int32_t argc, const Janet *argv) { peg_fixarity(b, argc, 2); Reserve r = reserve(b, 3); uint32_t subrule1 = peg_compile1(b, argv[0]); uint32_t subrule2 = peg_compile1(b, argv[1]); emit_2(r, RULE_SUB, subrule1, subrule2); } static void spec_til(Builder *b, int32_t argc, const Janet *argv) { peg_fixarity(b, argc, 2); Reserve r = reserve(b, 3); uint32_t subrule1 = peg_compile1(b, argv[0]); uint32_t subrule2 = peg_compile1(b, argv[1]); emit_2(r, RULE_TIL, subrule1, subrule2); } static void spec_split(Builder *b, int32_t argc, const Janet *argv) { peg_fixarity(b, argc, 2); Reserve r = reserve(b, 3); uint32_t subrule1 = peg_compile1(b, argv[0]); uint32_t subrule2 = peg_compile1(b, argv[1]); emit_2(r, RULE_SPLIT, subrule1, subrule2); } #ifdef JANET_INT_TYPES #define JANET_MAX_READINT_WIDTH 8 #else #define JANET_MAX_READINT_WIDTH 6 #endif static void spec_readint(Builder *b, int32_t argc, const Janet *argv, uint32_t mask) { peg_arity(b, argc, 1, 2); Reserve r = reserve(b, 3); uint32_t tag = (argc == 2) ? emit_tag(b, argv[1]) : 0; int32_t width = peg_getnat(b, argv[0]); if ((width < 0) || (width > JANET_MAX_READINT_WIDTH)) { peg_panicf(b, "width must be between 0 and %d, got %d", JANET_MAX_READINT_WIDTH, width); } emit_2(r, RULE_READINT, mask | ((uint32_t) width), tag); } static void spec_uint_le(Builder *b, int32_t argc, const Janet *argv) { spec_readint(b, argc, argv, 0x0u); } static void spec_int_le(Builder *b, int32_t argc, const Janet *argv) { spec_readint(b, argc, argv, 0x10u); } static void spec_uint_be(Builder *b, int32_t argc, const Janet *argv) { spec_readint(b, argc, argv, 0x20u); } static void spec_int_be(Builder *b, int32_t argc, const Janet *argv) { spec_readint(b, argc, argv, 0x30u); } /* Special compiler form */ typedef void (*Special)(Builder *b, int32_t argc, const Janet *argv); typedef struct { const char *name; Special special; } SpecialPair; /* Keep in lexical order (vim :sort works well) */ static const SpecialPair peg_specials[] = { {"!", spec_not}, {"$", spec_position}, {"%", spec_accumulate}, {"*", spec_sequence}, {"+", spec_choice}, {"->", spec_reference}, {"/", spec_replace}, {"<-", spec_capture}, {">", spec_look}, {"?", spec_opt}, {"??", spec_debug}, {"accumulate", spec_accumulate}, {"any", spec_any}, {"argument", spec_argument}, {"at-least", spec_atleast}, {"at-most", spec_atmost}, {"backmatch", spec_backmatch}, {"backref", spec_reference}, {"between", spec_between}, {"capture", spec_capture}, {"choice", spec_choice}, {"cms", spec_matchtime_splice}, {"cmt", spec_matchtime}, {"column", spec_column}, {"constant", spec_constant}, {"debug", spec_debug}, {"drop", spec_drop}, {"error", spec_error}, {"group", spec_group}, {"if", spec_if}, {"if-not", spec_ifnot}, {"int", spec_int_le}, {"int-be", spec_int_be}, {"lenprefix", spec_lenprefix}, {"line", spec_line}, {"look", spec_look}, {"not", spec_not}, {"nth", spec_nth}, {"number", spec_capture_number}, {"only-tags", spec_only_tags}, {"opt", spec_opt}, {"position", spec_position}, {"quote", spec_capture}, {"range", spec_range}, {"repeat", spec_repeat}, {"replace", spec_replace}, {"sequence", spec_sequence}, {"set", spec_set}, {"some", spec_some}, {"split", spec_split}, {"sub", spec_sub}, {"thru", spec_thru}, {"til", spec_til}, {"to", spec_to}, {"uint", spec_uint_le}, {"uint-be", spec_uint_be}, {"unref", spec_unref}, }; /* Compile a janet value into a rule and return the rule index. */ static uint32_t peg_compile1(Builder *b, Janet peg) { /* Keep track of the form being compiled for error purposes */ Janet old_form = b->form; JanetTable *old_grammar = b->grammar; b->form = peg; /* Resolve keyword references */ int i = JANET_RECURSION_GUARD; JanetTable *grammar = old_grammar; for (; i > 0 && janet_checktype(peg, JANET_KEYWORD); --i) { Janet nextPeg = janet_table_get_ex(grammar, peg, &grammar); if (!grammar || janet_checktype(nextPeg, JANET_NIL)) { nextPeg = (b->default_grammar == NULL) ? janet_wrap_nil() : janet_table_get(b->default_grammar, peg); if (janet_checktype(nextPeg, JANET_NIL)) { peg_panic(b, "unknown rule"); } } peg = nextPeg; b->form = peg; b->grammar = grammar; } if (i == 0) peg_panic(b, "reference chain too deep"); /* Check cache - for tuples we check only the local cache, as * in a different grammar, the same tuple can compile to a different * rule - for example, (+ :a :b) depends on whatever :a and :b are bound to. */ Janet check = janet_checktype(peg, JANET_TUPLE) ? janet_table_rawget(grammar, peg) : janet_table_get(grammar, peg); if (!janet_checktype(check, JANET_NIL)) { b->form = old_form; b->grammar = old_grammar; return (uint32_t) janet_unwrap_number(check); } /* Check depth */ if (b->depth-- == 0) peg_panic(b, "peg grammar recursed too deeply"); /* The final rule to return */ uint32_t rule = janet_v_count(b->bytecode); /* Add to cache. Do not cache structs, as we don't yet know * what rule they will return! We can just as effectively cache * the structs main rule. */ if (!janet_checktype(peg, JANET_STRUCT)) { JanetTable *which_grammar = grammar; /* If we are a primitive pattern, add to the global cache (root grammar table) */ if (!janet_checktype(peg, JANET_TUPLE)) { while (which_grammar->proto) which_grammar = which_grammar->proto; } janet_table_put(which_grammar, peg, janet_wrap_number(rule)); } switch (janet_type(peg)) { default: peg_panic(b, "unexpected peg source"); return 0; case JANET_BOOLEAN: { int n = janet_unwrap_boolean(peg); Reserve r = reserve(b, 2); emit_1(r, n ? RULE_NCHAR : RULE_NOTNCHAR, 0); break; } case JANET_NUMBER: { int32_t n = peg_getinteger(b, peg); Reserve r = reserve(b, 2); if (n < 0) { emit_1(r, RULE_NOTNCHAR, -n); } else { emit_1(r, RULE_NCHAR, n); } break; } case JANET_STRING: { const uint8_t *str = janet_unwrap_string(peg); int32_t len = janet_string_length(str); emit_bytes(b, RULE_LITERAL, len, str); break; } case JANET_BUFFER: { const JanetBuffer *buf = janet_unwrap_buffer(peg); emit_bytes(b, RULE_LITERAL, buf->count, buf->data); break; } case JANET_TABLE: { /* Build grammar table */ JanetTable *new_grammar = janet_table_clone(janet_unwrap_table(peg)); new_grammar->proto = grammar; b->grammar = grammar = new_grammar; /* Run the main rule */ Janet main_rule = janet_table_rawget(grammar, janet_ckeywordv("main")); if (janet_checktype(main_rule, JANET_NIL)) peg_panic(b, "grammar requires :main rule"); rule = peg_compile1(b, main_rule); break; } case JANET_STRUCT: { /* Build grammar table */ const JanetKV *st = janet_unwrap_struct(peg); JanetTable *new_grammar = janet_table(2 * janet_struct_capacity(st)); for (int32_t i = 0; i < janet_struct_capacity(st); i++) { if (janet_checktype(st[i].key, JANET_KEYWORD)) { janet_table_put(new_grammar, st[i].key, st[i].value); } } new_grammar->proto = grammar; b->grammar = grammar = new_grammar; /* Run the main rule */ Janet main_rule = janet_table_rawget(grammar, janet_ckeywordv("main")); if (janet_checktype(main_rule, JANET_NIL)) peg_panic(b, "grammar requires :main rule"); rule = peg_compile1(b, main_rule); break; } case JANET_TUPLE: { const Janet *tup = janet_unwrap_tuple(peg); int32_t len = janet_tuple_length(tup); if (len == 0) peg_panic(b, "tuple in grammar must have non-zero length"); if (janet_checkint(tup[0])) { int32_t n = janet_unwrap_integer(tup[0]); if (n < 0) { peg_panicf(b, "expected non-negative integer, got %d", n); } spec_repeat(b, len, tup); break; } if (!janet_checktype(tup[0], JANET_SYMBOL)) peg_panicf(b, "expected grammar command, found %v", tup[0]); const uint8_t *sym = janet_unwrap_symbol(tup[0]); const SpecialPair *sp = janet_strbinsearch( &peg_specials, sizeof(peg_specials) / sizeof(SpecialPair), sizeof(SpecialPair), sym); if (sp) { sp->special(b, len - 1, tup + 1); } else { peg_panicf(b, "unknown special %S", sym); } break; } } /* Increase depth again */ b->depth++; b->form = old_form; b->grammar = old_grammar; return rule; } /* * Post-Compilation */ static int peg_mark(void *p, size_t size) { (void) size; JanetPeg *peg = (JanetPeg *)p; if (NULL != peg->constants) for (uint32_t i = 0; i < peg->num_constants; i++) janet_mark(peg->constants[i]); return 0; } static void peg_marshal(void *p, JanetMarshalContext *ctx) { JanetPeg *peg = (JanetPeg *)p; janet_marshal_size(ctx, peg->bytecode_len); janet_marshal_int(ctx, (int32_t)peg->num_constants); janet_marshal_abstract(ctx, p); for (size_t i = 0; i < peg->bytecode_len; i++) janet_marshal_int(ctx, (int32_t) peg->bytecode[i]); for (uint32_t j = 0; j < peg->num_constants; j++) janet_marshal_janet(ctx, peg->constants[j]); } /* Used to ensure that if we place several arrays in one memory chunk, each * array will be correctly aligned */ static size_t size_padded(size_t offset, size_t size) { size_t x = size + offset - 1; return x - (x % size); } static void *peg_unmarshal(JanetMarshalContext *ctx) { size_t bytecode_len = janet_unmarshal_size(ctx); uint32_t num_constants = (uint32_t) janet_unmarshal_int(ctx); /* Calculate offsets. Should match those in make_peg */ size_t bytecode_start = size_padded(sizeof(JanetPeg), sizeof(uint32_t)); size_t bytecode_size = bytecode_len * sizeof(uint32_t); size_t constants_start = size_padded(bytecode_start + bytecode_size, sizeof(Janet)); size_t total_size = constants_start + sizeof(Janet) * (size_t) num_constants; /* DOS prevention? I.E. we could read bytecode and constants before * hand so we don't allocated a ton of memory on bad, short input */ /* Allocate PEG */ char *mem = janet_unmarshal_abstract(ctx, total_size); JanetPeg *peg = (JanetPeg *)mem; uint32_t *bytecode = (uint32_t *)(mem + bytecode_start); Janet *constants = (Janet *)(mem + constants_start); peg->bytecode = NULL; peg->constants = NULL; peg->bytecode_len = bytecode_len; peg->num_constants = num_constants; for (size_t i = 0; i < peg->bytecode_len; i++) bytecode[i] = (uint32_t) janet_unmarshal_int(ctx); for (uint32_t j = 0; j < peg->num_constants; j++) constants[j] = janet_unmarshal_janet(ctx); /* After here, no panics except for the bad: label. */ /* Keep track at each index if an instruction was * referenced (0x01) or is in a main bytecode position * (0x02). This lets us do a linear scan and not * need to a depth first traversal. It is stricter * than a dfs by not allowing certain kinds of unused * bytecode. */ uint32_t blen = (int32_t) peg->bytecode_len; uint32_t clen = peg->num_constants; uint8_t *op_flags = janet_calloc(1, blen); if (NULL == op_flags) { JANET_OUT_OF_MEMORY; } /* verify peg bytecode */ int32_t has_backref = 0; uint32_t i = 0; while (i < blen) { uint32_t instr = bytecode[i]; uint32_t *rule = bytecode + i; op_flags[i] |= 0x02; switch (instr) { case RULE_LITERAL: i += 2 + ((rule[1] + 3) >> 2); break; case RULE_DEBUG: /* [0 words] */ i += 1; break; case RULE_NCHAR: case RULE_NOTNCHAR: case RULE_RANGE: case RULE_POSITION: case RULE_LINE: case RULE_COLUMN: /* [1 word] */ i += 2; break; case RULE_BACKMATCH: /* [1 word] */ i += 2; has_backref = 1; break; case RULE_SET: /* [8 words] */ i += 9; break; case RULE_LOOK: /* [offset, rule] */ if (rule[2] >= blen) goto bad; op_flags[rule[2]] |= 0x1; i += 3; break; case RULE_CHOICE: case RULE_SEQUENCE: /* [len, rules...] */ { uint32_t len = rule[1]; for (uint32_t j = 0; j < len; j++) { if (rule[2 + j] >= blen) goto bad; op_flags[rule[2 + j]] |= 0x1; } i += 2 + len; } break; case RULE_IF: case RULE_IFNOT: case RULE_LENPREFIX: /* [rule_a, rule_b (b if not a)] */ if (rule[1] >= blen) goto bad; if (rule[2] >= blen) goto bad; op_flags[rule[1]] |= 0x01; op_flags[rule[2]] |= 0x01; i += 3; break; case RULE_BETWEEN: /* [lo, hi, rule] */ if (rule[3] >= blen) goto bad; op_flags[rule[3]] |= 0x01; i += 4; break; case RULE_ARGUMENT: /* [searchtag, tag] */ i += 3; break; case RULE_GETTAG: /* [searchtag, tag] */ i += 3; has_backref = 1; break; case RULE_CONSTANT: /* [constant, tag] */ if (rule[1] >= clen) goto bad; i += 3; break; case RULE_CAPTURE_NUM: /* [rule, base, tag] */ if (rule[1] >= blen) goto bad; op_flags[rule[1]] |= 0x01; i += 4; break; case RULE_ACCUMULATE: case RULE_GROUP: case RULE_CAPTURE: case RULE_UNREF: /* [rule, tag] */ if (rule[1] >= blen) goto bad; op_flags[rule[1]] |= 0x01; i += 3; break; case RULE_REPLACE: case RULE_MATCHTIME: case RULE_MATCHSPLICE: /* [rule, constant, tag] */ if (rule[1] >= blen) goto bad; if (rule[2] >= clen) goto bad; op_flags[rule[1]] |= 0x01; i += 4; break; case RULE_SUB: case RULE_TIL: case RULE_SPLIT: /* [rule, rule] */ if (rule[1] >= blen) goto bad; if (rule[2] >= blen) goto bad; op_flags[rule[1]] |= 0x01; op_flags[rule[2]] |= 0x01; i += 3; break; case RULE_ERROR: case RULE_DROP: case RULE_ONLY_TAGS: case RULE_NOT: case RULE_TO: case RULE_THRU: /* [rule] */ if (rule[1] >= blen) goto bad; op_flags[rule[1]] |= 0x01; i += 2; break; case RULE_READINT: /* [ width | (endianness << 5) | (signedness << 6), tag ] */ if (rule[1] > JANET_MAX_READINT_WIDTH) goto bad; i += 3; break; case RULE_NTH: /* [nth, rule, tag] */ if (rule[2] >= blen) goto bad; op_flags[rule[2]] |= 0x01; i += 4; break; default: goto bad; } } /* last instruction cannot overflow */ if (i != blen) goto bad; /* Make sure all referenced instructions are actually * in instruction positions. */ for (i = 0; i < blen; i++) if (op_flags[i] == 0x01) goto bad; /* Good return */ peg->bytecode = bytecode; peg->constants = constants; peg->has_backref = has_backref; janet_free(op_flags); return peg; bad: janet_free(op_flags); janet_panic("invalid peg bytecode"); } static int cfun_peg_getter(JanetAbstract a, Janet key, Janet *out); static Janet peg_next(void *p, Janet key); const JanetAbstractType janet_peg_type = { "core/peg", NULL, peg_mark, cfun_peg_getter, NULL, /* put */ peg_marshal, peg_unmarshal, NULL, /* tostring */ NULL, /* compare */ NULL, /* hash */ peg_next, JANET_ATEND_NEXT }; /* Convert Builder to JanetPeg (Janet Abstract Value) */ static JanetPeg *make_peg(Builder *b) { size_t bytecode_start = size_padded(sizeof(JanetPeg), sizeof(uint32_t)); size_t bytecode_size = janet_v_count(b->bytecode) * sizeof(uint32_t); size_t constants_start = size_padded(bytecode_start + bytecode_size, sizeof(Janet)); size_t constants_size = janet_v_count(b->constants) * sizeof(Janet); size_t total_size = constants_start + constants_size; char *mem = janet_abstract(&janet_peg_type, total_size); JanetPeg *peg = (JanetPeg *)mem; peg->bytecode = (uint32_t *)(mem + bytecode_start); peg->constants = (Janet *)(mem + constants_start); peg->num_constants = janet_v_count(b->constants); safe_memcpy(peg->bytecode, b->bytecode, bytecode_size); safe_memcpy(peg->constants, b->constants, constants_size); peg->bytecode_len = janet_v_count(b->bytecode); peg->has_backref = b->has_backref; return peg; } /* Compiler entry point */ static JanetPeg *compile_peg(Janet x) { Builder builder; builder.grammar = janet_table(0); builder.default_grammar = NULL; { Janet default_grammarv = janet_dyn("peg-grammar"); if (janet_checktype(default_grammarv, JANET_TABLE)) { builder.default_grammar = janet_unwrap_table(default_grammarv); } } builder.tags = janet_table(0); builder.constants = NULL; builder.bytecode = NULL; builder.nexttag = 1; builder.form = x; builder.depth = JANET_RECURSION_GUARD; builder.has_backref = 0; peg_compile1(&builder, x); JanetPeg *peg = make_peg(&builder); builder_cleanup(&builder); return peg; } /* * C Functions */ JANET_CORE_FN(cfun_peg_compile, "(peg/compile peg)", "Compiles a peg source data structure into a . This will speed up matching " "if the same peg will be used multiple times. `(dyn :peg-grammar)` replaces " "`default-peg-grammar` for the grammar of the peg.") { janet_fixarity(argc, 1); JanetPeg *peg = compile_peg(argv[0]); return janet_wrap_abstract(peg); } /* Common data for peg cfunctions */ typedef struct { JanetPeg *peg; PegState s; JanetByteView bytes; Janet subst; int32_t start; } PegCall; /* Initialize state for peg cfunctions */ static PegCall peg_cfun_init(int32_t argc, Janet *argv, int get_replace) { PegCall ret; int32_t min = get_replace ? 3 : 2; janet_arity(argc, min, -1); if (janet_checktype(argv[0], JANET_ABSTRACT) && janet_abstract_type(janet_unwrap_abstract(argv[0])) == &janet_peg_type) { ret.peg = janet_unwrap_abstract(argv[0]); } else { ret.peg = compile_peg(argv[0]); } if (get_replace) { ret.subst = argv[1]; ret.bytes = janet_getbytes(argv, 2); } else { ret.bytes = janet_getbytes(argv, 1); } if (argc > min) { ret.start = janet_gethalfrange(argv, min, ret.bytes.len, "offset"); ret.s.extrac = argc - min - 1; ret.s.extrav = janet_tuple_n(argv + min + 1, argc - min - 1); } else { ret.start = 0; ret.s.extrac = 0; ret.s.extrav = NULL; } ret.s.mode = PEG_MODE_NORMAL; ret.s.text_start = ret.bytes.bytes; ret.s.text_end = ret.bytes.bytes + ret.bytes.len; ret.s.outer_text_end = ret.s.text_end; ret.s.depth = JANET_RECURSION_GUARD; ret.s.captures = janet_array(0); ret.s.tagged_captures = janet_array(0); ret.s.scratch = janet_buffer(10); ret.s.tags = janet_buffer(10); ret.s.constants = ret.peg->constants; ret.s.bytecode = ret.peg->bytecode; ret.s.linemap = NULL; ret.s.linemaplen = -1; ret.s.has_backref = ret.peg->has_backref; return ret; } static void peg_call_reset(PegCall *c) { c->s.depth = JANET_RECURSION_GUARD; c->s.captures->count = 0; c->s.tagged_captures->count = 0; c->s.scratch->count = 0; c->s.tags->count = 0; } JANET_CORE_FN(cfun_peg_match, "(peg/match peg text &opt start & args)", "Match a Parsing Expression Grammar to a byte string and return an array of captured values. " "Returns nil if text does not match the language defined by peg. The syntax of PEGs is documented on the Janet website.") { PegCall c = peg_cfun_init(argc, argv, 0); const uint8_t *result = peg_rule(&c.s, c.s.bytecode, c.bytes.bytes + c.start); return result ? janet_wrap_array(c.s.captures) : janet_wrap_nil(); } JANET_CORE_FN(cfun_peg_find, "(peg/find peg text &opt start & args)", "Find first index where the peg matches in text. Returns an integer, or nil if not found.") { PegCall c = peg_cfun_init(argc, argv, 0); for (int32_t i = c.start; i < c.bytes.len; i++) { peg_call_reset(&c); if (peg_rule(&c.s, c.s.bytecode, c.bytes.bytes + i)) return janet_wrap_integer(i); } return janet_wrap_nil(); } JANET_CORE_FN(cfun_peg_find_all, "(peg/find-all peg text &opt start & args)", "Find all indexes where the peg matches in text. Returns an array of integers.") { PegCall c = peg_cfun_init(argc, argv, 0); JanetArray *ret = janet_array(0); for (int32_t i = c.start; i < c.bytes.len; i++) { peg_call_reset(&c); if (peg_rule(&c.s, c.s.bytecode, c.bytes.bytes + i)) janet_array_push(ret, janet_wrap_integer(i)); } return janet_wrap_array(ret); } static Janet cfun_peg_replace_generic(int32_t argc, Janet *argv, int only_one) { PegCall c = peg_cfun_init(argc, argv, 1); JanetBuffer *ret = janet_buffer(0); int32_t trail = 0; for (int32_t i = c.start; i < c.bytes.len;) { peg_call_reset(&c); const uint8_t *result = peg_rule(&c.s, c.s.bytecode, c.bytes.bytes + i); if (NULL != result) { if (trail < i) { janet_buffer_push_bytes(ret, c.bytes.bytes + trail, (i - trail)); trail = i; } int32_t nexti = (int32_t)(result - c.bytes.bytes); JanetByteView subst = janet_text_substitution(&c.subst, c.bytes.bytes + i, nexti - i, c.s.captures); janet_buffer_push_bytes(ret, subst.bytes, subst.len); trail = nexti; if (nexti == i) nexti++; i = nexti; if (only_one) break; } else { i++; } } if (trail < c.bytes.len) { janet_buffer_push_bytes(ret, c.bytes.bytes + trail, (c.bytes.len - trail)); } return janet_wrap_buffer(ret); } JANET_CORE_FN(cfun_peg_replace_all, "(peg/replace-all peg subst text &opt start & args)", "Replace all matches of `peg` in `text` with `subst`, returning a new buffer. " "The peg does not need to make captures to do replacement. " "If `subst` is a function, it will be called with the " "matching text followed by any captures.") { return cfun_peg_replace_generic(argc, argv, 0); } JANET_CORE_FN(cfun_peg_replace, "(peg/replace peg subst text &opt start & args)", "Replace first match of `peg` in `text` with `subst`, returning a new buffer. " "The peg does not need to make captures to do replacement. " "If `subst` is a function, it will be called with the " "matching text followed by any captures. " "If no matches are found, returns the input string in a new buffer.") { return cfun_peg_replace_generic(argc, argv, 1); } static JanetMethod peg_methods[] = { {"match", cfun_peg_match}, {"find", cfun_peg_find}, {"find-all", cfun_peg_find_all}, {"replace", cfun_peg_replace}, {"replace-all", cfun_peg_replace_all}, {NULL, NULL} }; static int cfun_peg_getter(JanetAbstract a, Janet key, Janet *out) { (void) a; if (!janet_checktype(key, JANET_KEYWORD)) return 0; return janet_getmethod(janet_unwrap_keyword(key), peg_methods, out); } static Janet peg_next(void *p, Janet key) { (void) p; return janet_nextmethod(peg_methods, key); } /* Load the peg module */ void janet_lib_peg(JanetTable *env) { JanetRegExt cfuns[] = { JANET_CORE_REG("peg/compile", cfun_peg_compile), JANET_CORE_REG("peg/match", cfun_peg_match), JANET_CORE_REG("peg/find", cfun_peg_find), JANET_CORE_REG("peg/find-all", cfun_peg_find_all), JANET_CORE_REG("peg/replace", cfun_peg_replace), JANET_CORE_REG("peg/replace-all", cfun_peg_replace_all), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, cfuns); janet_register_abstract_type(&janet_peg_type); } #endif /* ifdef JANET_PEG */ janet-1.41.2/src/core/pp.c000066400000000000000000001204441514534607600152220ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "util.h" #include "state.h" #include #endif #include #include #include #include /* Implements a pretty printer for Janet. The pretty printer * is simple and not that flexible, but fast. */ /* Temporary buffer size */ #define BUFSIZE 64 /* Preprocessor hacks */ #define STR_HELPER(x) #x #define STR(x) STR_HELPER(x) static void number_to_string_b(JanetBuffer *buffer, double x) { janet_buffer_ensure(buffer, buffer->count + BUFSIZE, 2); const char *fmt = (x == floor(x) && x <= JANET_INTMAX_DOUBLE && x >= JANET_INTMIN_DOUBLE) ? "%.0f" : ("%." STR(DBL_DIG) "g"); int count; if (x == 0.0) { /* Prevent printing of '-0' */ count = 1; buffer->data[buffer->count] = '0'; } else { count = snprintf((char *) buffer->data + buffer->count, BUFSIZE, fmt, x); } buffer->count += count; } /* expects non positive x */ static int count_dig10(int32_t x) { int result = 1; for (;;) { if (x > -10) return result; if (x > -100) return result + 1; if (x > -1000) return result + 2; if (x > -10000) return result + 3; x /= 10000; result += 4; } } static void integer_to_string_b(JanetBuffer *buffer, int32_t x) { janet_buffer_extra(buffer, BUFSIZE); uint8_t *buf = buffer->data + buffer->count; int32_t neg = 0; int32_t len = 0; if (x == 0) { buf[0] = '0'; buffer->count++; return; } if (x > 0) { x = -x; } else { neg = 1; *buf++ = '-'; } len = count_dig10(x); buf += len; while (x) { uint8_t digit = (uint8_t) - (x % 10); *(--buf) = '0' + digit; x /= 10; } buffer->count += len + neg; } #define HEX(i) (((uint8_t *) janet_base64)[(i)]) /* Returns a string description for a pointer. Truncates * title to 32 characters */ static void string_description_b(JanetBuffer *buffer, const char *title, void *pointer) { janet_buffer_ensure(buffer, buffer->count + BUFSIZE, 2); uint8_t *c = buffer->data + buffer->count; int32_t i; union { uint8_t bytes[sizeof(void *)]; void *p; } pbuf; pbuf.p = pointer; *c++ = '<'; /* Maximum of 32 bytes for abstract type name */ for (i = 0; i < 32 && title[i]; ++i) *c++ = ((uint8_t *)title) [i]; *c++ = ' '; *c++ = '0'; *c++ = 'x'; #if defined(JANET_64) #define POINTSIZE 6 #else #define POINTSIZE (sizeof(void *)) #endif for (i = POINTSIZE; i > 0; --i) { uint8_t byte = pbuf.bytes[i - 1]; *c++ = HEX(byte >> 4); *c++ = HEX(byte & 0xF); } *c++ = '>'; buffer->count = (int32_t)(c - buffer->data); #undef POINTSIZE } static void janet_escape_string_impl(JanetBuffer *buffer, const uint8_t *str, int32_t len) { janet_buffer_push_u8(buffer, '"'); for (int32_t i = 0; i < len; ++i) { uint8_t c = str[i]; switch (c) { case '"': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\\"", 2); break; case '\n': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\n", 2); break; case '\r': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\r", 2); break; case '\0': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\0", 2); break; case '\f': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\f", 2); break; case '\v': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\v", 2); break; case '\a': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\a", 2); break; case '\b': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\b", 2); break; case 27: janet_buffer_push_bytes(buffer, (const uint8_t *)"\\e", 2); break; case '\\': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\\\", 2); break; case '\t': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\t", 2); break; default: if (c < 32 || c > 126) { uint8_t buf[4]; buf[0] = '\\'; buf[1] = 'x'; buf[2] = janet_base64[(c >> 4) & 0xF]; buf[3] = janet_base64[c & 0xF]; janet_buffer_push_bytes(buffer, buf, 4); } else { janet_buffer_push_u8(buffer, c); } break; } } janet_buffer_push_u8(buffer, '"'); } static void janet_escape_string_b(JanetBuffer *buffer, const uint8_t *str) { janet_escape_string_impl(buffer, str, janet_string_length(str)); } static void janet_escape_buffer_b(JanetBuffer *buffer, JanetBuffer *bx) { if (bx == buffer) { /* Ensures buffer won't resize while escaping */ janet_buffer_ensure(bx, bx->count + 5 * bx->count + 3, 1); } janet_buffer_push_u8(buffer, '@'); janet_escape_string_impl(buffer, bx->data, bx->count); } void janet_to_string_b(JanetBuffer *buffer, Janet x) { switch (janet_type(x)) { case JANET_NIL: janet_buffer_push_cstring(buffer, ""); break; case JANET_BOOLEAN: janet_buffer_push_cstring(buffer, janet_unwrap_boolean(x) ? "true" : "false"); break; case JANET_NUMBER: number_to_string_b(buffer, janet_unwrap_number(x)); break; case JANET_STRING: case JANET_SYMBOL: case JANET_KEYWORD: janet_buffer_push_bytes(buffer, janet_unwrap_string(x), janet_string_length(janet_unwrap_string(x))); break; case JANET_BUFFER: { JanetBuffer *to = janet_unwrap_buffer(x); /* Prevent resizing buffer while appending */ if (buffer == to) janet_buffer_extra(buffer, to->count); janet_buffer_push_bytes(buffer, to->data, to->count); break; } case JANET_ABSTRACT: { JanetAbstract p = janet_unwrap_abstract(x); const JanetAbstractType *t = janet_abstract_type(p); if (t->tostring != NULL) { t->tostring(p, buffer); } else { string_description_b(buffer, t->name, p); } } return; case JANET_CFUNCTION: { JanetCFunRegistry *reg = janet_registry_get(janet_unwrap_cfunction(x)); if (NULL != reg) { janet_buffer_push_cstring(buffer, "name_prefix) { janet_buffer_push_cstring(buffer, reg->name_prefix); janet_buffer_push_u8(buffer, '/'); } janet_buffer_push_cstring(buffer, reg->name); janet_buffer_push_u8(buffer, '>'); break; } goto fallthrough; } case JANET_FUNCTION: { JanetFunction *fun = janet_unwrap_function(x); JanetFuncDef *def = fun->def; if (def == NULL) { janet_buffer_push_cstring(buffer, ""); break; } if (def->name) { const uint8_t *n = def->name; janet_buffer_push_cstring(buffer, "'); break; } goto fallthrough; } fallthrough: default: string_description_b(buffer, janet_type_names[janet_type(x)], janet_unwrap_pointer(x)); break; } } /* See parse.c for full table */ /* Check if a symbol or keyword contains no symbol characters */ static int contains_bad_chars(const uint8_t *sym, int issym) { int32_t len = janet_string_length(sym); if (len && issym && sym[0] >= '0' && sym[0] <= '9') return 1; if (!janet_valid_utf8(sym, len)) return 1; for (int32_t i = 0; i < len; i++) { if (!janet_is_symbol_char(sym[i])) return 1; } return 0; } void janet_description_b(JanetBuffer *buffer, Janet x) { switch (janet_type(x)) { default: break; case JANET_NIL: janet_buffer_push_cstring(buffer, "nil"); return; case JANET_KEYWORD: janet_buffer_push_u8(buffer, ':'); break; case JANET_STRING: janet_escape_string_b(buffer, janet_unwrap_string(x)); return; case JANET_BUFFER: { JanetBuffer *b = janet_unwrap_buffer(x); janet_escape_buffer_b(buffer, b); return; } case JANET_ABSTRACT: { JanetAbstract p = janet_unwrap_abstract(x); const JanetAbstractType *t = janet_abstract_type(p); if (t->tostring != NULL) { janet_buffer_push_cstring(buffer, "<"); janet_buffer_push_cstring(buffer, t->name); janet_buffer_push_cstring(buffer, " "); t->tostring(p, buffer); janet_buffer_push_cstring(buffer, ">"); } else { string_description_b(buffer, t->name, p); } return; } } janet_to_string_b(buffer, x); } const uint8_t *janet_description(Janet x) { JanetBuffer b; janet_buffer_init(&b, 10); janet_description_b(&b, x); const uint8_t *ret = janet_string(b.data, b.count); janet_buffer_deinit(&b); return ret; } /* Convert any value to a janet string. Similar to description, but * strings, symbols, and buffers will return their content. */ const uint8_t *janet_to_string(Janet x) { switch (janet_type(x)) { default: { JanetBuffer b; janet_buffer_init(&b, 10); janet_to_string_b(&b, x); const uint8_t *ret = janet_string(b.data, b.count); janet_buffer_deinit(&b); return ret; } case JANET_BUFFER: return janet_string(janet_unwrap_buffer(x)->data, janet_unwrap_buffer(x)->count); case JANET_STRING: case JANET_SYMBOL: case JANET_KEYWORD: return janet_unwrap_string(x); } } /* Hold state for pretty printer. */ struct pretty { JanetBuffer *buffer; int depth; int indent; int flags; int32_t bufstartlen; int32_t *keysort_buffer; int32_t keysort_capacity; int32_t keysort_start; JanetTable seen; }; /* Print jdn format */ static int print_jdn_one(struct pretty *S, Janet x, int depth) { if (depth == 0) return 1; switch (janet_type(x)) { case JANET_NIL: case JANET_BOOLEAN: case JANET_BUFFER: case JANET_STRING: janet_description_b(S->buffer, x); break; case JANET_NUMBER: janet_buffer_ensure(S->buffer, S->buffer->count + BUFSIZE, 2); double num = janet_unwrap_number(x); if (isnan(num)) return 1; if (isinf(num)) return 1; janet_buffer_dtostr(S->buffer, num); break; case JANET_SYMBOL: case JANET_KEYWORD: if (contains_bad_chars(janet_unwrap_keyword(x), janet_type(x) == JANET_SYMBOL)) return 1; janet_description_b(S->buffer, x); break; case JANET_TUPLE: { JanetTuple t = janet_unwrap_tuple(x); int isb = janet_tuple_flag(t) & JANET_TUPLE_FLAG_BRACKETCTOR; janet_buffer_push_u8(S->buffer, isb ? '[' : '('); for (int32_t i = 0; i < janet_tuple_length(t); i++) { if (i) janet_buffer_push_u8(S->buffer, ' '); if (print_jdn_one(S, t[i], depth - 1)) return 1; } janet_buffer_push_u8(S->buffer, isb ? ']' : ')'); } break; case JANET_ARRAY: { janet_table_put(&S->seen, x, janet_wrap_true()); JanetArray *a = janet_unwrap_array(x); janet_buffer_push_cstring(S->buffer, "@["); for (int32_t i = 0; i < a->count; i++) { if (i) janet_buffer_push_u8(S->buffer, ' '); if (print_jdn_one(S, a->data[i], depth - 1)) return 1; } janet_buffer_push_u8(S->buffer, ']'); } break; case JANET_TABLE: { janet_table_put(&S->seen, x, janet_wrap_true()); JanetTable *tab = janet_unwrap_table(x); janet_buffer_push_cstring(S->buffer, "@{"); int isFirst = 1; for (int32_t i = 0; i < tab->capacity; i++) { const JanetKV *kv = tab->data + i; if (janet_checktype(kv->key, JANET_NIL)) continue; if (!isFirst) janet_buffer_push_u8(S->buffer, ' '); isFirst = 0; if (print_jdn_one(S, kv->key, depth - 1)) return 1; janet_buffer_push_u8(S->buffer, ' '); if (print_jdn_one(S, kv->value, depth - 1)) return 1; } janet_buffer_push_u8(S->buffer, '}'); } break; case JANET_STRUCT: { JanetStruct st = janet_unwrap_struct(x); janet_buffer_push_u8(S->buffer, '{'); int isFirst = 1; for (int32_t i = 0; i < janet_struct_capacity(st); i++) { const JanetKV *kv = st + i; if (janet_checktype(kv->key, JANET_NIL)) continue; if (!isFirst) janet_buffer_push_u8(S->buffer, ' '); isFirst = 0; if (print_jdn_one(S, kv->key, depth - 1)) return 1; janet_buffer_push_u8(S->buffer, ' '); if (print_jdn_one(S, kv->value, depth - 1)) return 1; } janet_buffer_push_u8(S->buffer, '}'); } break; default: return 1; } return 0; } static void print_newline(struct pretty *S, int just_a_space) { int i; if (just_a_space || (S->flags & JANET_PRETTY_ONELINE)) { janet_buffer_push_u8(S->buffer, ' '); return; } janet_buffer_push_u8(S->buffer, '\n'); for (i = 0; i < S->indent; i++) { janet_buffer_push_u8(S->buffer, ' '); } } /* Color coding for types */ static const char janet_cycle_color[] = "\x1B[36m"; static const char janet_class_color[] = "\x1B[34m"; static const char *janet_pretty_colors[] = { "\x1B[32m", "\x1B[36m", "\x1B[36m", "\x1B[36m", "\x1B[35m", "\x1B[34m", "\x1B[33m", "\x1B[36m", "\x1B[36m", "\x1B[36m", "\x1B[36m", "\x1B[35m", "\x1B[36m", "\x1B[36m", "\x1B[36m", "\x1B[36m" }; #define JANET_PRETTY_DICT_ONELINE 4 #define JANET_PRETTY_IND_ONELINE 10 #define JANET_PRETTY_DICT_LIMIT 30 #define JANET_PRETTY_DICT_KEYSORT_LIMIT 2000 #define JANET_PRETTY_ARRAY_LIMIT 160 /* Helper for pretty printing */ static void janet_pretty_one(struct pretty *S, Janet x, int is_dict_value) { /* Add to seen */ switch (janet_type(x)) { case JANET_NIL: case JANET_NUMBER: case JANET_SYMBOL: case JANET_BOOLEAN: break; default: { Janet seenid = janet_table_get(&S->seen, x); if (janet_checktype(seenid, JANET_NUMBER)) { if (S->flags & JANET_PRETTY_COLOR) { janet_buffer_push_cstring(S->buffer, janet_cycle_color); } janet_buffer_push_cstring(S->buffer, "buffer, janet_unwrap_integer(seenid)); janet_buffer_push_u8(S->buffer, '>'); if (S->flags & JANET_PRETTY_COLOR) { janet_buffer_push_cstring(S->buffer, "\x1B[0m"); } return; } else { janet_table_put(&S->seen, x, janet_wrap_integer(S->seen.count)); break; } } } switch (janet_type(x)) { default: { const char *color = janet_pretty_colors[janet_type(x)]; if (color && (S->flags & JANET_PRETTY_COLOR)) { janet_buffer_push_cstring(S->buffer, color); } if (janet_checktype(x, JANET_BUFFER) && janet_unwrap_buffer(x) == S->buffer) { janet_buffer_ensure(S->buffer, S->buffer->count + S->bufstartlen * 4 + 3, 1); janet_buffer_push_u8(S->buffer, '@'); janet_escape_string_impl(S->buffer, S->buffer->data, S->bufstartlen); } else { janet_description_b(S->buffer, x); } if (color && (S->flags & JANET_PRETTY_COLOR)) { janet_buffer_push_cstring(S->buffer, "\x1B[0m"); } break; } case JANET_ARRAY: case JANET_TUPLE: { int32_t i = 0, len = 0; const Janet *arr = NULL; int isarray = janet_checktype(x, JANET_ARRAY); janet_indexed_view(x, &arr, &len); int hasbrackets = !isarray && (janet_tuple_flag(arr) & JANET_TUPLE_FLAG_BRACKETCTOR); const char *startstr = isarray ? "@[" : hasbrackets ? "[" : "("; const char endchar = isarray ? ']' : hasbrackets ? ']' : ')'; janet_buffer_push_cstring(S->buffer, startstr); S->depth--; S->indent += 2; if (S->depth == 0) { janet_buffer_push_cstring(S->buffer, "..."); } else { if (!isarray && !(S->flags & JANET_PRETTY_ONELINE) && len >= JANET_PRETTY_IND_ONELINE) janet_buffer_push_u8(S->buffer, ' '); if (is_dict_value && len >= JANET_PRETTY_IND_ONELINE) print_newline(S, 0); if (len > JANET_PRETTY_ARRAY_LIMIT && !(S->flags & JANET_PRETTY_NOTRUNC)) { for (i = 0; i < 3; i++) { if (i) print_newline(S, 0); janet_pretty_one(S, arr[i], 0); } print_newline(S, 0); janet_buffer_push_cstring(S->buffer, "..."); for (i = 0; i < 3; i++) { print_newline(S, 0); janet_pretty_one(S, arr[len - 3 + i], 0); } } else { for (i = 0; i < len; i++) { if (i) print_newline(S, len < JANET_PRETTY_IND_ONELINE); janet_pretty_one(S, arr[i], 0); } } } S->indent -= 2; S->depth++; janet_buffer_push_u8(S->buffer, endchar); break; } case JANET_STRUCT: case JANET_TABLE: { int istable = janet_checktype(x, JANET_TABLE); /* For object-like tables, print class name */ if (istable) { JanetTable *t = janet_unwrap_table(x); JanetTable *proto = t->proto; janet_buffer_push_cstring(S->buffer, "@"); if (NULL != proto) { Janet name = janet_table_get(proto, janet_ckeywordv("_name")); const uint8_t *n; int32_t len; if (janet_bytes_view(name, &n, &len)) { if (S->flags & JANET_PRETTY_COLOR) { janet_buffer_push_cstring(S->buffer, janet_class_color); } janet_buffer_push_bytes(S->buffer, n, len); if (S->flags & JANET_PRETTY_COLOR) { janet_buffer_push_cstring(S->buffer, "\x1B[0m"); } } } } else { JanetStruct st = janet_unwrap_struct(x); JanetStruct proto = janet_struct_proto(st); if (NULL != proto) { Janet name = janet_struct_get(proto, janet_ckeywordv("_name")); const uint8_t *n; int32_t len; if (janet_bytes_view(name, &n, &len)) { if (S->flags & JANET_PRETTY_COLOR) { janet_buffer_push_cstring(S->buffer, janet_class_color); } janet_buffer_push_bytes(S->buffer, n, len); if (S->flags & JANET_PRETTY_COLOR) { janet_buffer_push_cstring(S->buffer, "\x1B[0m"); } } } } janet_buffer_push_cstring(S->buffer, "{"); S->depth--; S->indent += 2; if (S->depth == 0) { janet_buffer_push_cstring(S->buffer, "..."); } else { int32_t len = 0, cap = 0; const JanetKV *kvs = NULL; janet_dictionary_view(x, &kvs, &len, &cap); if (!istable && !(S->flags & JANET_PRETTY_ONELINE) && len >= JANET_PRETTY_DICT_ONELINE) janet_buffer_push_u8(S->buffer, ' '); if (is_dict_value && len >= JANET_PRETTY_DICT_ONELINE) print_newline(S, 0); int32_t ks_start = S->keysort_start; int truncated = 0; /* Shortcut for huge dictionaries, don't bother sorting keys */ if (len > JANET_PRETTY_DICT_KEYSORT_LIMIT) { if (!(S->flags & JANET_PRETTY_NOTRUNC) && (len > JANET_PRETTY_DICT_LIMIT)) { len = JANET_PRETTY_DICT_LIMIT; truncated = 1; } int32_t j = 0; for (int32_t i = 0; i < len; i++) { while (janet_checktype(kvs[j].key, JANET_NIL)) j++; if (i) print_newline(S, len < JANET_PRETTY_DICT_ONELINE); janet_pretty_one(S, kvs[j].key, 0); janet_buffer_push_u8(S->buffer, ' '); janet_pretty_one(S, kvs[j].value, 1); j++; } if (truncated) { print_newline(S, 0); janet_buffer_push_cstring(S->buffer, "..."); } } else { /* Sorted keys dictionaries */ /* Ensure buffer is large enough to sort keys. */ int64_t mincap = (int64_t) len + (int64_t) ks_start; if (mincap > INT32_MAX) { truncated = 1; len = 0; mincap = ks_start; } if (S->keysort_capacity < mincap) { if (mincap >= INT32_MAX / 2) { S->keysort_capacity = INT32_MAX; } else { S->keysort_capacity = (int32_t)(mincap * 2); } S->keysort_buffer = janet_srealloc(S->keysort_buffer, sizeof(int32_t) * S->keysort_capacity); if (NULL == S->keysort_buffer) { JANET_OUT_OF_MEMORY; } } janet_sorted_keys(kvs, cap, S->keysort_buffer == NULL ? NULL : S->keysort_buffer + ks_start); S->keysort_start += len; if (!(S->flags & JANET_PRETTY_NOTRUNC) && (len > JANET_PRETTY_DICT_LIMIT)) { len = JANET_PRETTY_DICT_LIMIT; truncated = 1; } for (int32_t i = 0; i < len; i++) { if (i) print_newline(S, len < JANET_PRETTY_DICT_ONELINE); int32_t j = S->keysort_buffer[i + ks_start]; janet_pretty_one(S, kvs[j].key, 0); janet_buffer_push_u8(S->buffer, ' '); janet_pretty_one(S, kvs[j].value, 1); } if (truncated) { print_newline(S, 0); janet_buffer_push_cstring(S->buffer, "..."); } } S->keysort_start = ks_start; } S->indent -= 2; S->depth++; janet_buffer_push_u8(S->buffer, '}'); break; } } /* Remove from seen */ janet_table_remove(&S->seen, x); return; } static JanetBuffer *janet_pretty_(JanetBuffer *buffer, int depth, int flags, Janet x, int32_t startlen) { struct pretty S; if (NULL == buffer) { buffer = janet_buffer(0); } S.buffer = buffer; S.depth = depth; S.indent = 0; S.flags = flags; S.bufstartlen = startlen; S.keysort_capacity = 0; S.keysort_buffer = NULL; S.keysort_start = 0; janet_table_init(&S.seen, 10); janet_pretty_one(&S, x, 0); janet_table_deinit(&S.seen); return S.buffer; } /* Helper for printing a janet value in a pretty form. Not meant to be used * for serialization or anything like that. */ JanetBuffer *janet_pretty(JanetBuffer *buffer, int depth, int flags, Janet x) { return janet_pretty_(buffer, depth, flags, x, buffer ? buffer->count : 0); } static JanetBuffer *janet_jdn_(JanetBuffer *buffer, int depth, Janet x, int32_t startlen) { struct pretty S; if (NULL == buffer) { buffer = janet_buffer(0); } S.buffer = buffer; S.depth = depth; S.indent = 0; S.flags = 0; S.bufstartlen = startlen; S.keysort_capacity = 0; S.keysort_buffer = NULL; S.keysort_start = 0; janet_table_init(&S.seen, 10); int res = print_jdn_one(&S, x, depth); janet_table_deinit(&S.seen); if (res) { janet_panic("could not print to jdn format"); } return S.buffer; } JanetBuffer *janet_jdn(JanetBuffer *buffer, int depth, Janet x) { return janet_jdn_(buffer, depth, x, buffer ? buffer->count : 0); } static const char *typestr(Janet x) { JanetType t = janet_type(x); return (t == JANET_ABSTRACT) ? janet_abstract_type(janet_unwrap_abstract(x))->name : janet_type_names[t]; } static void pushtypes(JanetBuffer *buffer, int types) { int first = 1; int i = 0; while (types) { if (1 & types) { if (first) { first = 0; } else { janet_buffer_push_cstring(buffer, (types == 1) ? " or " : ", "); } janet_buffer_push_cstring(buffer, janet_type_names[i]); } i++; types >>= 1; } } /* * code adapted from lua/lstrlib.c http://lua.org */ #define MAX_ITEM 256 #define FMT_FLAGS "-+ #0" #define FMT_REPLACE_INTTYPES "diouxX" #define MAX_FORMAT 32 struct FmtMapping { char c; const char *mapping; }; /* Janet uses fixed width integer types for most things, so map * format specifiers to these fixed sizes */ static const struct FmtMapping format_mappings[] = { {'D', PRId64}, {'I', PRIi64}, {'d', PRId64}, {'i', PRIi64}, {'o', PRIo64}, {'u', PRIu64}, {'x', PRIx64}, {'X', PRIX64}, }; static const char *get_fmt_mapping(char c) { for (size_t i = 0; i < (sizeof(format_mappings) / sizeof(struct FmtMapping)); i++) { if (format_mappings[i].c == c) return format_mappings[i].mapping; } janet_assert(0, "bad format mapping"); } static const char *scanformat( const char *strfrmt, char *form, char width[3], char precision[3]) { const char *p = strfrmt; /* Parse strfrmt */ memset(width, '\0', 3); memset(precision, '\0', 3); while (*p != '\0' && strchr(FMT_FLAGS, *p) != NULL) p++; /* skip flags */ if ((size_t)(p - strfrmt) >= sizeof(FMT_FLAGS)) janet_panic("invalid format (repeated flags)"); if (isdigit((int)(*p))) width[0] = *p++; /* skip width */ if (isdigit((int)(*p))) width[1] = *p++; /* (2 digits at most) */ if (*p == '.') { p++; if (isdigit((int)(*p))) precision[0] = *p++; /* skip precision */ if (isdigit((int)(*p))) precision[1] = *p++; /* (2 digits at most) */ } if (isdigit((int)(*p))) janet_panic("invalid format (width or precision too long)"); /* Write to form - replace characters with fixed size stuff */ *(form++) = '%'; const char *p2 = strfrmt; while (p2 <= p) { char *loc = strchr(FMT_REPLACE_INTTYPES, *p2); if (loc != NULL && *loc != '\0') { const char *mapping = get_fmt_mapping(*p2++); size_t len = strlen(mapping); memcpy(form, mapping, len); form += len; } else { *(form++) = *(p2++); } } *form = '\0'; return p; } void janet_formatbv(JanetBuffer *b, const char *format, va_list args) { const char *format_end = format + strlen(format); const char *c = format; int32_t startlen = b->count; while (c < format_end) { if (*c != '%') { janet_buffer_push_u8(b, (uint8_t) *c++); } else if (*++c == '%') { janet_buffer_push_u8(b, (uint8_t) *c++); } else { char form[MAX_FORMAT], item[MAX_ITEM]; char width[3], precision[3]; int nb = 0; /* number of bytes in added item */ c = scanformat(c, form, width, precision); switch (*c++) { case 'c': { int n = va_arg(args, int); nb = snprintf(item, MAX_ITEM, form, n); break; } case 'd': case 'i': { int64_t n = (int64_t) va_arg(args, int32_t); nb = snprintf(item, MAX_ITEM, form, n); break; } case 'D': case 'I': { int64_t n = va_arg(args, int64_t); nb = snprintf(item, MAX_ITEM, form, n); break; } case 'x': case 'X': case 'o': case 'u': { uint64_t n = va_arg(args, uint64_t); nb = snprintf(item, MAX_ITEM, form, n); break; } case 'a': case 'A': case 'e': case 'E': case 'f': case 'g': case 'G': { double d = va_arg(args, double); nb = snprintf(item, MAX_ITEM, form, d); break; } case 's': case 'S': { const char *str = va_arg(args, const char *); int32_t len = (c[-1] == 's') ? (int32_t) strlen(str) : janet_string_length((JanetString) str); if (form[2] == '\0') janet_buffer_push_bytes(b, (const uint8_t *) str, len); else { if (len != (int32_t) strlen((const char *) str)) janet_panic("string contains zeros"); if (!strchr(form, '.') && len >= 100) { janet_panic("no precision and string is too long to be formatted"); } else { nb = snprintf(item, MAX_ITEM, form, str); } } break; } case 'V': janet_to_string_b(b, va_arg(args, Janet)); break; case 'v': janet_description_b(b, va_arg(args, Janet)); break; case 't': janet_buffer_push_cstring(b, typestr(va_arg(args, Janet))); break; case 'T': { int types = va_arg(args, int); pushtypes(b, types); break; } case 'M': case 'm': case 'N': case 'n': case 'Q': case 'q': case 'P': case 'p': { /* janet pretty , precision = depth */ int depth = atoi(precision); if (depth < 1) depth = JANET_RECURSION_GUARD; char d = c[-1]; int has_color = (d == 'P') || (d == 'Q') || (d == 'M') || (d == 'N'); int has_oneline = (d == 'Q') || (d == 'q') || (d == 'N') || (d == 'n'); int has_notrunc = (d == 'M') || (d == 'm') || (d == 'N') || (d == 'n'); int flags = 0; flags |= has_color ? JANET_PRETTY_COLOR : 0; flags |= has_oneline ? JANET_PRETTY_ONELINE : 0; flags |= has_notrunc ? JANET_PRETTY_NOTRUNC : 0; janet_pretty_(b, depth, flags, va_arg(args, Janet), startlen); break; } case 'j': { int depth = atoi(precision); if (depth < 1) depth = JANET_RECURSION_GUARD; janet_jdn_(b, depth, va_arg(args, Janet), startlen); break; } default: { /* also treat cases 'nLlh' */ janet_panicf("invalid conversion '%s' to 'format'", form); } } if (nb >= MAX_ITEM) janet_panic("format buffer overflow"); if (nb > 0) janet_buffer_push_bytes(b, (uint8_t *) item, nb); } } } /* Helper function for formatting strings. Useful for generating error messages and the like. * Similar to printf, but specialized for operating with janet. */ const uint8_t *janet_formatc(const char *format, ...) { va_list args; const uint8_t *ret; JanetBuffer buffer; int32_t len = 0; /* Calculate length, init buffer and args */ while (format[len]) len++; janet_buffer_init(&buffer, len); va_start(args, format); /* Run format */ janet_formatbv(&buffer, format, args); /* Iterate length */ va_end(args); ret = janet_string(buffer.data, buffer.count); janet_buffer_deinit(&buffer); return ret; } JanetBuffer *janet_formatb(JanetBuffer *buffer, const char *format, ...) { va_list args; va_start(args, format); janet_formatbv(buffer, format, args); va_end(args); return buffer; } /* Shared implementation between string/format and * buffer/format */ void janet_buffer_format( JanetBuffer *b, const char *strfrmt, int32_t argstart, int32_t argc, Janet *argv) { size_t sfl = strlen(strfrmt); const char *strfrmt_end = strfrmt + sfl; int32_t arg = argstart; int32_t startlen = b->count; while (strfrmt < strfrmt_end) { if (*strfrmt != '%') janet_buffer_push_u8(b, (uint8_t) * strfrmt++); else if (*++strfrmt == '%') janet_buffer_push_u8(b, (uint8_t) * strfrmt++); /* %% */ else { /* format item */ char form[MAX_FORMAT], item[MAX_ITEM]; char width[3], precision[3]; int nb = 0; /* number of bytes in added item */ #ifdef JANET_PLAN9 if (*strfrmt == 'r') { rerrstr(item, MAX_ITEM); nb = strlen(item); } else #endif if (++arg >= argc) janet_panic("not enough values for format"); strfrmt = scanformat(strfrmt, form, width, precision); switch (*strfrmt++) { #ifdef JANET_PLAN9 case 'r': break; #endif case 'c': { nb = snprintf(item, MAX_ITEM, form, (int) janet_getinteger(argv, arg)); break; } case 'D': case 'I': case 'd': case 'i': { int64_t n = janet_getinteger64(argv, arg); nb = snprintf(item, MAX_ITEM, form, n); break; } case 'x': case 'X': case 'o': case 'u': { uint64_t n = janet_getuinteger64(argv, arg); nb = snprintf(item, MAX_ITEM, form, n); break; } case 'a': case 'A': case 'e': case 'E': case 'f': case 'g': case 'G': { double d = janet_getnumber(argv, arg); nb = snprintf(item, MAX_ITEM, form, d); break; } case 's': { const char *s = janet_getcbytes(argv, arg); if (form[2] == '\0') janet_buffer_push_cstring(b, s); else { nb = snprintf(item, MAX_ITEM, form, s); } break; } case 'V': { janet_to_string_b(b, argv[arg]); break; } case 'v': { janet_description_b(b, argv[arg]); break; } case 't': janet_buffer_push_cstring(b, typestr(argv[arg])); break; case 'M': case 'm': case 'N': case 'n': case 'Q': case 'q': case 'P': case 'p': { /* janet pretty , precision = depth */ int depth = atoi(precision); if (depth < 1) depth = JANET_RECURSION_GUARD; char d = strfrmt[-1]; int has_color = (d == 'P') || (d == 'Q') || (d == 'M') || (d == 'N'); int has_oneline = (d == 'Q') || (d == 'q') || (d == 'N') || (d == 'n'); int has_notrunc = (d == 'M') || (d == 'm') || (d == 'N') || (d == 'n'); int flags = 0; flags |= has_color ? JANET_PRETTY_COLOR : 0; flags |= has_oneline ? JANET_PRETTY_ONELINE : 0; flags |= has_notrunc ? JANET_PRETTY_NOTRUNC : 0; janet_pretty_(b, depth, flags, argv[arg], startlen); break; } case 'j': { int depth = atoi(precision); if (depth < 1) depth = JANET_RECURSION_GUARD; janet_jdn_(b, depth, argv[arg], startlen); break; } default: { /* also treat cases 'nLlh' */ janet_panicf("invalid conversion '%s' to 'format'", form); } } if (nb >= MAX_ITEM) janet_panic("format buffer overflow"); if (nb > 0) janet_buffer_push_bytes(b, (uint8_t *) item, nb); } } } #undef HEX #undef BUFSIZE janet-1.41.2/src/core/regalloc.c000066400000000000000000000124021514534607600163650ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "regalloc.h" #include "util.h" #endif /* The JanetRegisterAllocator is really just a bitset. */ void janetc_regalloc_init(JanetcRegisterAllocator *ra) { ra->chunks = NULL; ra->count = 0; ra->capacity = 0; ra->max = 0; ra->regtemps = 0; } void janetc_regalloc_deinit(JanetcRegisterAllocator *ra) { janet_free(ra->chunks); } /* Fallbacks for when ctz not available */ #ifdef __GNUC__ #define count_trailing_zeros(x) __builtin_ctz(x) #define count_trailing_ones(x) __builtin_ctz(~(x)) #else static int32_t count_trailing_ones(uint32_t x) { int32_t ret = 0; while (x & 1) { ret++; x >>= 1; } return ret; } #define count_trailing_zeros(x) count_trailing_ones(~(x)) #endif /* Get ith bit */ #define ithbit(I) ((uint32_t)1 << (I)) /* Get N bits */ #define nbits(N) (ithbit(N) - 1) /* Copy a register allocator */ void janetc_regalloc_clone(JanetcRegisterAllocator *dest, JanetcRegisterAllocator *src) { size_t size; dest->count = src->count; dest->capacity = src->capacity; dest->max = src->max; size = sizeof(uint32_t) * (size_t) dest->capacity; dest->regtemps = 0; if (size) { dest->chunks = janet_malloc(size); if (!dest->chunks) { JANET_OUT_OF_MEMORY; } memcpy(dest->chunks, src->chunks, size); } else { dest->chunks = NULL; } } /* Allocate one more chunk in chunks */ static void pushchunk(JanetcRegisterAllocator *ra) { /* Registers 240-255 are always allocated (reserved) */ uint32_t chunk = ra->count == 7 ? 0xFFFF0000 : 0; int32_t newcount = ra->count + 1; if (newcount > ra->capacity) { int32_t newcapacity = newcount * 2; ra->chunks = janet_realloc(ra->chunks, (size_t) newcapacity * sizeof(uint32_t)); if (!ra->chunks) { JANET_OUT_OF_MEMORY; } ra->capacity = newcapacity; } ra->chunks[ra->count] = chunk; ra->count = newcount; } /* Reallocate a given register */ void janetc_regalloc_touch(JanetcRegisterAllocator *ra, int32_t reg) { int32_t chunk = reg >> 5; int32_t bit = reg & 0x1F; while (chunk >= ra->count) pushchunk(ra); ra->chunks[chunk] |= ithbit(bit); } /* Allocate one register. */ int32_t janetc_regalloc_1(JanetcRegisterAllocator *ra) { /* Get the nth bit in the array */ int32_t bit, chunk, nchunks, reg; bit = -1; nchunks = ra->count; for (chunk = 0; chunk < nchunks; chunk++) { uint32_t block = ra->chunks[chunk]; if (block == 0xFFFFFFFF) continue; bit = count_trailing_ones(block); break; } /* No reg found */ if (bit == -1) { pushchunk(ra); bit = 0; chunk = nchunks; } /* set the bit at index bit in chunk */ ra->chunks[chunk] |= ithbit(bit); reg = (chunk << 5) + bit; if (reg > ra->max) ra->max = reg; return reg; } /* Free a register. The register must have been previously allocated * without being freed. */ void janetc_regalloc_free(JanetcRegisterAllocator *ra, int32_t reg) { int32_t chunk = reg >> 5; int32_t bit = reg & 0x1F; ra->chunks[chunk] &= ~ithbit(bit); } /* Check if a register is set. */ int janetc_regalloc_check(JanetcRegisterAllocator *ra, int32_t reg) { int32_t chunk = reg >> 5; int32_t bit = reg & 0x1F; while (chunk >= ra->count) pushchunk(ra); return !!(ra->chunks[chunk] & ithbit(bit)); } /* Get a register that will fit in 8 bits (< 256). Do not call this * twice with the same value of nth without calling janetc_regalloc_free * on the returned register before. */ int32_t janetc_regalloc_temp(JanetcRegisterAllocator *ra, JanetcRegisterTemp nth) { int32_t oldmax = ra->max; if (ra->regtemps & (1 << nth)) { JANET_EXIT("regtemp already allocated"); } ra->regtemps |= 1 << nth; int32_t reg = janetc_regalloc_1(ra); if (reg > 0xFF) { reg = 0xF0 + nth; ra->max = (reg > oldmax) ? reg : oldmax; } return reg; } void janetc_regalloc_freetemp(JanetcRegisterAllocator *ra, int32_t reg, JanetcRegisterTemp nth) { ra->regtemps &= ~(1 << nth); if (reg < 0xF0) janetc_regalloc_free(ra, reg); } janet-1.41.2/src/core/regalloc.h000066400000000000000000000046471514534607600164060ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ /* Implements a simple first fit register allocator for the compiler. */ #ifndef JANET_REGALLOC_H #define JANET_REGALLOC_H #include /* Placeholder for allocating temporary registers */ typedef enum { JANETC_REGTEMP_0, JANETC_REGTEMP_1, JANETC_REGTEMP_2, JANETC_REGTEMP_3, JANETC_REGTEMP_4, JANETC_REGTEMP_5, JANETC_REGTEMP_6, JANETC_REGTEMP_7 } JanetcRegisterTemp; typedef struct { uint32_t *chunks; int32_t count; /* number of chunks in chunks */ int32_t capacity; /* amount allocated for chunks */ int32_t max; /* The maximum allocated register so far */ int32_t regtemps; /* Hold which temp. registers are allocated. */ } JanetcRegisterAllocator; void janetc_regalloc_init(JanetcRegisterAllocator *ra); void janetc_regalloc_deinit(JanetcRegisterAllocator *ra); int32_t janetc_regalloc_1(JanetcRegisterAllocator *ra); void janetc_regalloc_free(JanetcRegisterAllocator *ra, int32_t reg); int32_t janetc_regalloc_temp(JanetcRegisterAllocator *ra, JanetcRegisterTemp nth); void janetc_regalloc_freetemp(JanetcRegisterAllocator *ra, int32_t reg, JanetcRegisterTemp nth); void janetc_regalloc_clone(JanetcRegisterAllocator *dest, JanetcRegisterAllocator *src); void janetc_regalloc_touch(JanetcRegisterAllocator *ra, int32_t reg); int janetc_regalloc_check(JanetcRegisterAllocator *ra, int32_t reg); #endif janet-1.41.2/src/core/run.c000066400000000000000000000143031514534607600154030ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "state.h" #endif /* Run a string of code. The return value is a set of error flags, JANET_DO_ERROR_RUNTIME, JANET_DO_ERROR_COMPILE, and JANET_DOR_ERROR_PARSE if * any errors were encountered in those phases. More information is printed to stderr. */ int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char *sourcePath, Janet *out) { JanetParser *parser; int errflags = 0, done = 0; int32_t index = 0; Janet ret = janet_wrap_nil(); JanetFiber *fiber = NULL; const uint8_t *where = sourcePath ? janet_cstring(sourcePath) : NULL; if (where) janet_gcroot(janet_wrap_string(where)); if (NULL == sourcePath) sourcePath = ""; parser = janet_abstract(&janet_parser_type, sizeof(JanetParser)); janet_parser_init(parser); janet_gcroot(janet_wrap_abstract(parser)); /* While we haven't seen an error */ while (!done) { /* Evaluate parsed values */ while (janet_parser_has_more(parser)) { Janet form = janet_parser_produce(parser); JanetCompileResult cres = janet_compile(form, env, where); if (cres.status == JANET_COMPILE_OK) { JanetFunction *f = janet_thunk(cres.funcdef); fiber = janet_fiber(f, 64, 0, NULL); fiber->env = env; JanetSignal status = janet_continue(fiber, janet_wrap_nil(), &ret); if (status != JANET_SIGNAL_OK && status != JANET_SIGNAL_EVENT) { janet_stacktrace_ext(fiber, ret, ""); errflags |= JANET_DO_ERROR_RUNTIME; done = 1; } } else { int32_t line = (int32_t) parser->line; int32_t col = (int32_t) parser->column; if ((cres.error_mapping.line > 0) && (cres.error_mapping.column > 0)) { line = cres.error_mapping.line; col = cres.error_mapping.column; } JanetString ctx = janet_formatc("%s:%d:%d: compile error", sourcePath, line, col); JanetString errstr = janet_formatc("%s: %s", (const char *)ctx, (const char *)cres.error); ret = janet_wrap_string(errstr); if (cres.macrofiber) { janet_eprintf("%s", (const char *)ctx); janet_stacktrace_ext(cres.macrofiber, ret, ""); } else { janet_eprintf("%s\n", (const char *)errstr); } errflags |= JANET_DO_ERROR_COMPILE; done = 1; } } if (done) break; /* Dispatch based on parse state */ switch (janet_parser_status(parser)) { case JANET_PARSE_DEAD: done = 1; break; case JANET_PARSE_ERROR: { errflags |= JANET_DO_ERROR_PARSE; int32_t line = (int32_t) parser->line; int32_t col = (int32_t) parser->column; JanetString errstr = janet_formatc("%s:%d:%d: parse error: %s", sourcePath, line, col, janet_parser_error(parser)); ret = janet_wrap_string(errstr); janet_eprintf("%s\n", (const char *)errstr); done = 1; break; } case JANET_PARSE_ROOT: case JANET_PARSE_PENDING: if (index >= len) { janet_parser_eof(parser); } else { janet_parser_consume(parser, bytes[index++]); } break; } } /* Clean up and return errors */ janet_gcunroot(janet_wrap_abstract(parser)); if (where) janet_gcunroot(janet_wrap_string(where)); #ifdef JANET_EV /* Enter the event loop if we are not already in it */ if (janet_vm.stackn == 0) { if (fiber) { janet_gcroot(janet_wrap_fiber(fiber)); } janet_loop(); if (fiber) { janet_gcunroot(janet_wrap_fiber(fiber)); if (!errflags) ret = fiber->last_value; } } #endif if (out) *out = ret; return errflags; } int janet_dostring(JanetTable *env, const char *str, const char *sourcePath, Janet *out) { int32_t len = 0; while (str[len]) ++len; return janet_dobytes(env, (const uint8_t *)str, len, sourcePath, out); } /* Run a fiber to completion (use event loop if enabled). Return the status. */ int janet_loop_fiber(JanetFiber *fiber) { int status; #ifdef JANET_EV janet_schedule(fiber, janet_wrap_nil()); janet_loop(); status = janet_fiber_status(fiber); #else Janet out; status = janet_continue(fiber, janet_wrap_nil(), &out); if (status != JANET_SIGNAL_OK && status != JANET_SIGNAL_EVENT) { janet_stacktrace_ext(fiber, out, ""); } #endif return status; } janet-1.41.2/src/core/specials.c000066400000000000000000001274771514534607600164230ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "compile.h" #include "util.h" #include "vector.h" #include "emit.h" #endif static JanetSlot janetc_quote(JanetFopts opts, int32_t argn, const Janet *argv) { if (argn != 1) { janetc_cerror(opts.compiler, "expected 1 argument to quote"); return janetc_cslot(janet_wrap_nil()); } return janetc_cslot(argv[0]); } static JanetSlot janetc_splice(JanetFopts opts, int32_t argn, const Janet *argv) { JanetSlot ret; if (!(opts.flags & JANET_FOPTS_ACCEPT_SPLICE)) { janetc_cerror(opts.compiler, "splice can only be used in function parameters and data constructors, it has no effect here"); return janetc_cslot(janet_wrap_nil()); } if (argn != 1) { janetc_cerror(opts.compiler, "expected 1 argument to splice"); return janetc_cslot(janet_wrap_nil()); } ret = janetc_value(opts, argv[0]); ret.flags |= JANET_SLOT_SPLICED; return ret; } static JanetSlot qq_slots(JanetFopts opts, JanetSlot *slots, int makeop) { JanetSlot target = janetc_gettarget(opts); janetc_pushslots(opts.compiler, slots); janetc_freeslots(opts.compiler, slots); janetc_emit_s(opts.compiler, makeop, target, 1); return target; } static JanetSlot quasiquote(JanetFopts opts, Janet x, int depth, int level) { if (depth == 0) { janetc_cerror(opts.compiler, "quasiquote too deeply nested"); return janetc_cslot(janet_wrap_nil()); } JanetSlot *slots = NULL; JanetFopts subopts = opts; subopts.flags &= ~JANET_FOPTS_HINT; switch (janet_type(x)) { default: return janetc_cslot(x); case JANET_TUPLE: { int32_t i, len; const Janet *tup = janet_unwrap_tuple(x); len = janet_tuple_length(tup); if (len > 1 && janet_checktype(tup[0], JANET_SYMBOL)) { const uint8_t *head = janet_unwrap_symbol(tup[0]); if (!janet_cstrcmp(head, "unquote")) { if (level == 0) { JanetFopts subopts = janetc_fopts_default(opts.compiler); subopts.flags |= JANET_FOPTS_ACCEPT_SPLICE; return janetc_value(subopts, tup[1]); } else { level--; } } else if (!janet_cstrcmp(head, "quasiquote")) { level++; } } for (i = 0; i < len; i++) janet_v_push(slots, quasiquote(subopts, tup[i], depth - 1, level)); return qq_slots(opts, slots, (janet_tuple_flag(tup) & JANET_TUPLE_FLAG_BRACKETCTOR) ? JOP_MAKE_BRACKET_TUPLE : JOP_MAKE_TUPLE); } case JANET_ARRAY: { int32_t i; JanetArray *array = janet_unwrap_array(x); for (i = 0; i < array->count; i++) janet_v_push(slots, quasiquote(subopts, array->data[i], depth - 1, level)); return qq_slots(opts, slots, JOP_MAKE_ARRAY); } case JANET_TABLE: case JANET_STRUCT: { const JanetKV *kv = NULL, *kvs = NULL; int32_t len, cap = 0; janet_dictionary_view(x, &kvs, &len, &cap); while ((kv = janet_dictionary_next(kvs, cap, kv))) { JanetSlot key = quasiquote(subopts, kv->key, depth - 1, level); JanetSlot value = quasiquote(subopts, kv->value, depth - 1, level); key.flags &= ~JANET_SLOT_SPLICED; value.flags &= ~JANET_SLOT_SPLICED; janet_v_push(slots, key); janet_v_push(slots, value); } return qq_slots(opts, slots, janet_checktype(x, JANET_TABLE) ? JOP_MAKE_TABLE : JOP_MAKE_STRUCT); } } } static JanetSlot janetc_quasiquote(JanetFopts opts, int32_t argn, const Janet *argv) { if (argn != 1) { janetc_cerror(opts.compiler, "expected 1 argument to quasiquote"); return janetc_cslot(janet_wrap_nil()); } return quasiquote(opts, argv[0], JANET_RECURSION_GUARD, 0); } static JanetSlot janetc_unquote(JanetFopts opts, int32_t argn, const Janet *argv) { (void) argn; (void) argv; janetc_cerror(opts.compiler, "cannot use unquote here"); return janetc_cslot(janet_wrap_nil()); } /* Perform destructuring. Be careful to * keep the order registers are freed. * Returns if the slot 'right' can be freed. */ static int destructure(JanetCompiler *c, Janet left, JanetSlot right, int (*leaf)(JanetCompiler *c, const uint8_t *sym, JanetSlot s, JanetTable *attr), JanetTable *attr) { switch (janet_type(left)) { default: janetc_error(c, janet_formatc("unexpected type in destructuring, got %v", left)); return 1; case JANET_SYMBOL: /* Leaf, assign right to left */ return leaf(c, janet_unwrap_symbol(left), right, attr); case JANET_TUPLE: case JANET_ARRAY: { int32_t len = 0; const Janet *values = NULL; janet_indexed_view(left, &values, &len); for (int32_t i = 0; i < len; i++) { JanetSlot nextright = janetc_farslot(c); Janet subval = values[i]; if (janet_checktype(subval, JANET_SYMBOL) && !janet_cstrcmp(janet_unwrap_symbol(subval), "&")) { if (i + 1 >= len) { janetc_cerror(c, "expected symbol following '& in destructuring pattern"); return 1; } if (i + 2 < len) { int32_t num_extra = len - i - 1; Janet *extra = janet_tuple_begin(num_extra); janet_tuple_flag(extra) |= JANET_TUPLE_FLAG_BRACKETCTOR; for (int32_t j = 0; j < num_extra; ++j) { extra[j] = values[j + i + 1]; } janetc_error(c, janet_formatc("expected a single symbol follow '& in destructuring pattern, found %q", janet_wrap_tuple(janet_tuple_end(extra)))); return 1; } if (!janet_checktype(values[i + 1], JANET_SYMBOL)) { janetc_error(c, janet_formatc("expected symbol following '& in destructuring pattern, found %q", values[i + 1])); return 1; } JanetSlot argi = janetc_farslot(c); JanetSlot arg = janetc_farslot(c); JanetSlot len = janetc_farslot(c); janetc_emit_si(c, JOP_LOAD_INTEGER, argi, i, 0); janetc_emit_ss(c, JOP_LENGTH, len, right, 0); /* loop condition - reuse arg slot for the condition result */ int32_t label_loop_start = janetc_emit_sss(c, JOP_LESS_THAN, arg, argi, len, 0); int32_t label_loop_cond_jump = janetc_emit_si(c, JOP_JUMP_IF_NOT, arg, 0, 0); /* loop body */ janetc_emit_sss(c, JOP_GET, arg, right, argi, 0); janetc_emit_s(c, JOP_PUSH, arg, 0); janetc_emit_ssi(c, JOP_ADD_IMMEDIATE, argi, argi, 1, 0); /* loop - jump back to the start of the loop */ int32_t label_loop_loop = janet_v_count(c->buffer); janetc_emit(c, JOP_JUMP); int32_t label_loop_exit = janet_v_count(c->buffer); /* avoid shifting negative numbers */ c->buffer[label_loop_cond_jump] |= (uint32_t)(label_loop_exit - label_loop_cond_jump) << 16; c->buffer[label_loop_loop] |= (uint32_t)(label_loop_start - label_loop_loop) << 8; janetc_freeslot(c, argi); janetc_freeslot(c, arg); janetc_freeslot(c, len); janetc_emit_s(c, JOP_MAKE_TUPLE, nextright, 1); leaf(c, janet_unwrap_symbol(values[i + 1]), nextright, attr); janetc_freeslot(c, nextright); break; } if (i < 0x100) { janetc_emit_ssu(c, JOP_GET_INDEX, nextright, right, (uint8_t) i, 1); } else { JanetSlot k = janetc_cslot(janet_wrap_integer(i)); janetc_emit_sss(c, JOP_IN, nextright, right, k, 1); } if (destructure(c, subval, nextright, leaf, attr)) janetc_freeslot(c, nextright); } } return 1; case JANET_TABLE: case JANET_STRUCT: { const JanetKV *kvs = NULL; int32_t cap = 0, len = 0; janet_dictionary_view(left, &kvs, &len, &cap); for (int32_t i = 0; i < cap; i++) { if (janet_checktype(kvs[i].key, JANET_NIL)) continue; JanetSlot nextright = janetc_farslot(c); JanetSlot k = janetc_value(janetc_fopts_default(c), kvs[i].key); janetc_emit_sss(c, JOP_IN, nextright, right, k, 1); if (destructure(c, kvs[i].value, nextright, leaf, attr)) janetc_freeslot(c, nextright); } } return 1; } } /* Create a source map for definitions. */ static const Janet *janetc_make_sourcemap(JanetCompiler *c) { Janet *tup = janet_tuple_begin(3); tup[0] = c->source ? janet_wrap_string(c->source) : janet_wrap_nil(); tup[1] = janet_wrap_integer(c->current_mapping.line); tup[2] = janet_wrap_integer(c->current_mapping.column); return janet_tuple_end(tup); } static JanetSlot janetc_varset(JanetFopts opts, int32_t argn, const Janet *argv) { if (argn != 2) { janetc_cerror(opts.compiler, "expected 2 arguments to set"); return janetc_cslot(janet_wrap_nil()); } JanetFopts subopts = janetc_fopts_default(opts.compiler); if (janet_checktype(argv[0], JANET_SYMBOL)) { /* Normal var - (set a 1) */ const uint8_t *sym = janet_unwrap_symbol(argv[0]); JanetSlot dest = janetc_resolve(opts.compiler, sym); if (!(dest.flags & JANET_SLOT_MUTABLE)) { janetc_cerror(opts.compiler, "cannot set constant"); return janetc_cslot(janet_wrap_nil()); } subopts.flags = JANET_FOPTS_HINT; subopts.hint = dest; JanetSlot ret = janetc_value(subopts, argv[1]); janetc_copy(opts.compiler, dest, ret); return ret; } else if (janet_checktype(argv[0], JANET_TUPLE)) { /* Set a field (setf behavior) - (set (tab :key) 2) */ const Janet *tup = janet_unwrap_tuple(argv[0]); /* Tuple must have 2 elements */ if (janet_tuple_length(tup) != 2) { janetc_cerror(opts.compiler, "expected 2 element tuple for l-value to set"); return janetc_cslot(janet_wrap_nil()); } JanetSlot ds = janetc_value(subopts, tup[0]); JanetSlot key = janetc_value(subopts, tup[1]); /* Can't be tail position because we will emit a PUT instruction afterwards */ /* Also can't drop either */ opts.flags &= ~(JANET_FOPTS_TAIL | JANET_FOPTS_DROP); JanetSlot rvalue = janetc_value(opts, argv[1]); /* Emit the PUT instruction */ janetc_emit_sss(opts.compiler, JOP_PUT, ds, key, rvalue, 0); return rvalue; } else { /* Error */ janetc_cerror(opts.compiler, "expected symbol or tuple for l-value to set"); return janetc_cslot(janet_wrap_nil()); } } /* Add attributes to a global def or var table */ static JanetTable *handleattr(JanetCompiler *c, const char *kind, int32_t argn, const Janet *argv) { int32_t i; if (argn < 2) { janetc_error(c, janet_formatc("expected at least 2 arguments to %s", kind)); return NULL; } JanetTable *tab = janet_table(2); const char *binding_name = janet_type(argv[0]) == JANET_SYMBOL ? ((const char *)janet_unwrap_symbol(argv[0])) : ""; for (i = 1; i < argn - 1; i++) { Janet attr = argv[i]; switch (janet_type(attr)) { case JANET_TUPLE: janetc_cerror(c, "unexpected form - did you intend to use defn?"); break; default: janetc_error(c, janet_formatc("cannot add metadata %v to binding %s", attr, binding_name)); break; case JANET_KEYWORD: janet_table_put(tab, attr, janet_wrap_true()); break; case JANET_STRING: janet_table_put(tab, janet_ckeywordv("doc"), attr); break; case JANET_STRUCT: janet_table_merge_struct(tab, janet_unwrap_struct(attr)); break; } } return tab; } typedef struct SlotHeadPair { Janet lhs; JanetSlot rhs; } SlotHeadPair; SlotHeadPair *dohead_destructure(JanetCompiler *c, SlotHeadPair *into, JanetFopts opts, Janet lhs, Janet rhs) { /* Detect if we can do an optimization to avoid some allocations */ int can_destructure_lhs = janet_checktype(lhs, JANET_TUPLE) || janet_checktype(lhs, JANET_ARRAY); int rhs_is_indexed = janet_checktype(rhs, JANET_ARRAY) || (janet_checktype(rhs, JANET_TUPLE) && (janet_tuple_flag(janet_unwrap_tuple(rhs)) & JANET_TUPLE_FLAG_BRACKETCTOR)); uint32_t has_drop = opts.flags & JANET_FOPTS_DROP; JanetFopts subopts = janetc_fopts_default(c); subopts.flags = opts.flags & ~(JANET_FOPTS_TAIL | JANET_FOPTS_DROP); if (has_drop && can_destructure_lhs && rhs_is_indexed) { /* Code is of the form (def [a b] [1 2]), avoid the allocation of two tuples */ JanetView view_lhs = {0}; JanetView view_rhs = {0}; janet_indexed_view(lhs, &view_lhs.items, &view_lhs.len); janet_indexed_view(rhs, &view_rhs.items, &view_rhs.len); int found_amp = 0; int found_splice = 0; /* Check for (def [x y z] [(splice [1 2 3]) 4 5 6]), bail out of optimization */ for (int32_t i = 0; i < view_rhs.len; i++) { if (!janet_checktype(view_rhs.items[i], JANET_TUPLE)) { continue; } JanetTuple tup = janet_unwrap_tuple(view_rhs.items[i]); if (janet_tuple_length(tup) == 0) { continue; } if (janet_symeq(tup[0], "splice")) { found_splice = 1; /* Good error will be generated later. */ break; } } /* Check for (def [x & more] [1 2 3]), bail out of optimization */ for (int32_t i = 0; i < view_lhs.len; i++) { if (janet_symeq(view_lhs.items[i], "&")) { found_amp = 1; /* Good error will be generated later. */ break; } } if (!found_amp && !found_splice) { for (int32_t i = 0; i < view_lhs.len; i++) { Janet sub_rhs = view_rhs.len <= i ? janet_wrap_nil() : view_rhs.items[i]; into = dohead_destructure(c, into, subopts, view_lhs.items[i], sub_rhs); } return into; } } /* No optimization, do the simple way */ subopts.hint = opts.hint; JanetSlot ret = janetc_value(subopts, rhs); SlotHeadPair shp = {lhs, ret}; janet_v_push(into, shp); return into; } /* Def or var a symbol in a local scope */ static int namelocal(JanetCompiler *c, const uint8_t *head, int32_t flags, JanetSlot ret, int no_unused) { int isUnnamedRegister = !(ret.flags & JANET_SLOT_NAMED) && ret.index > 0 && ret.envindex >= 0; /* optimization for `(def x my-def)` - don't emit a movn/movf instruction, we can just alias my-def */ /* TODO - implement optimization for `(def x my-var)` correctly as well w/ de-aliasing */ int canAlias = !(flags & JANET_SLOT_MUTABLE) && !(ret.flags & JANET_SLOT_MUTABLE) && (ret.flags & JANET_SLOT_NAMED) && (ret.index >= 0) && (ret.envindex == -1); if (canAlias) { ret.flags &= ~JANET_SLOT_MUTABLE; isUnnamedRegister = 1; /* don't free slot after use - is an alias for another slot */ } else if (!isUnnamedRegister) { /* Slot is not able to be named */ JanetSlot localslot = janetc_farslot(c); janetc_copy(c, localslot, ret); ret = localslot; } ret.flags |= flags; if ((c->scope->flags & JANET_SCOPE_TOP) || no_unused) { janetc_nameslot_no_unused(c, head, ret); } else { janetc_nameslot(c, head, ret); } return !isUnnamedRegister; } static int varleaf( JanetCompiler *c, const uint8_t *sym, JanetSlot s, JanetTable *reftab) { if (c->scope->flags & JANET_SCOPE_TOP) { /* Global var, generate var */ JanetSlot refslot; JanetTable *entry = janet_table_clone(reftab); int is_redef = janet_truthy(janet_table_get_keyword(c->env, "redef")); JanetArray *ref; JanetBinding old_binding; if (is_redef && (old_binding = janet_resolve_ext(c->env, sym), old_binding.type == JANET_BINDING_VAR)) { ref = janet_unwrap_array(old_binding.value); } else { ref = janet_array(1); janet_array_push(ref, janet_wrap_nil()); } janet_table_put(entry, janet_ckeywordv("ref"), janet_wrap_array(ref)); janet_table_put(entry, janet_ckeywordv("source-map"), janet_wrap_tuple(janetc_make_sourcemap(c))); janet_table_put(c->env, janet_wrap_symbol(sym), janet_wrap_table(entry)); refslot = janetc_cslot(janet_wrap_array(ref)); janetc_emit_ssu(c, JOP_PUT_INDEX, refslot, s, 0, 0); return 1; } else { int no_unused = reftab && reftab->count && janet_truthy(janet_table_get_keyword(reftab, "unused")); return namelocal(c, sym, JANET_SLOT_MUTABLE, s, no_unused); } } static void check_metadata_lint(JanetCompiler *c, JanetTable *attr_table) { if (!(c->scope->flags & JANET_SCOPE_TOP) && attr_table && attr_table->count) { /* A macro is a normal lint, other metadata is a strict lint */ if (janet_truthy(janet_table_get_keyword(attr_table, "macro"))) { janetc_lintf(c, JANET_C_LINT_NORMAL, "macro tag is ignored in inner scopes"); } } } static JanetSlot janetc_var(JanetFopts opts, int32_t argn, const Janet *argv) { JanetCompiler *c = opts.compiler; JanetTable *attr_table = handleattr(c, "var", argn, argv); if (c->result.status == JANET_COMPILE_ERROR) { return janetc_cslot(janet_wrap_nil()); } check_metadata_lint(c, attr_table); SlotHeadPair *into = NULL; into = dohead_destructure(c, into, opts, argv[0], argv[argn - 1]); if (c->result.status == JANET_COMPILE_ERROR) { janet_v_free(into); return janetc_cslot(janet_wrap_nil()); } JanetSlot ret; janet_assert(janet_v_count(into) > 0, "bad destructure"); for (int32_t i = 0; i < janet_v_count(into); i++) { destructure(c, into[i].lhs, into[i].rhs, varleaf, attr_table); ret = into[i].rhs; } janet_v_free(into); return ret; } static int defleaf( JanetCompiler *c, const uint8_t *sym, JanetSlot s, JanetTable *tab) { if (c->scope->flags & JANET_SCOPE_TOP) { JanetTable *entry = janet_table_clone(tab); janet_table_put(entry, janet_ckeywordv("source-map"), janet_wrap_tuple(janetc_make_sourcemap(c))); int is_redef = janet_truthy(janet_table_get_keyword(c->env, "redef")); if (is_redef) janet_table_put(entry, janet_ckeywordv("redef"), janet_wrap_true()); if (is_redef) { JanetBinding binding = janet_resolve_ext(c->env, sym); JanetArray *ref; if (binding.type == JANET_BINDING_DYNAMIC_DEF || binding.type == JANET_BINDING_DYNAMIC_MACRO) { ref = janet_unwrap_array(binding.value); } else { ref = janet_array(1); janet_array_push(ref, janet_wrap_nil()); } janet_table_put(entry, janet_ckeywordv("ref"), janet_wrap_array(ref)); JanetSlot refslot = janetc_cslot(janet_wrap_array(ref)); janetc_emit_ssu(c, JOP_PUT_INDEX, refslot, s, 0, 0); } else { JanetSlot valsym = janetc_cslot(janet_ckeywordv("value")); JanetSlot tabslot = janetc_cslot(janet_wrap_table(entry)); janetc_emit_sss(c, JOP_PUT, tabslot, valsym, s, 0); } /* Add env entry to env */ janet_table_put(c->env, janet_wrap_symbol(sym), janet_wrap_table(entry)); } int no_unused = tab && tab->count && janet_truthy(janet_table_get_keyword(tab, "unused")); return namelocal(c, sym, 0, s, no_unused); } static JanetSlot janetc_def(JanetFopts opts, int32_t argn, const Janet *argv) { JanetCompiler *c = opts.compiler; JanetTable *attr_table = handleattr(c, "def", argn, argv); if (c->result.status == JANET_COMPILE_ERROR) { return janetc_cslot(janet_wrap_nil()); } check_metadata_lint(c, attr_table); opts.flags &= ~JANET_FOPTS_HINT; SlotHeadPair *into = NULL; into = dohead_destructure(c, into, opts, argv[0], argv[argn - 1]); if (c->result.status == JANET_COMPILE_ERROR) { janet_v_free(into); return janetc_cslot(janet_wrap_nil()); } JanetSlot ret; janet_assert(janet_v_count(into) > 0, "bad destructure"); for (int32_t i = 0; i < janet_v_count(into); i++) { destructure(c, into[i].lhs, into[i].rhs, defleaf, attr_table); ret = into[i].rhs; } janet_v_free(into); return ret; } /* Check if a form matches the pattern (= nil _) or (not= nil _) */ static int janetc_check_nil_form(Janet x, Janet *capture, uint32_t fun_tag) { if (!janet_checktype(x, JANET_TUPLE)) return 0; JanetTuple tup = janet_unwrap_tuple(x); if (3 != janet_tuple_length(tup)) return 0; Janet op1 = tup[0]; if (!janet_checktype(op1, JANET_FUNCTION)) return 0; JanetFunction *fun = janet_unwrap_function(op1); uint32_t tag = fun->def->flags & JANET_FUNCDEF_FLAG_TAG; if (tag != fun_tag) return 0; if (janet_checktype(tup[1], JANET_NIL)) { *capture = tup[2]; return 1; } else if (janet_checktype(tup[2], JANET_NIL)) { *capture = tup[1]; return 1; } return 0; } /* * :condition * ... * jump-if-not condition :right * :left * ... * jump done (only if not tail) * :right * ... * :done */ static JanetSlot janetc_if(JanetFopts opts, int32_t argn, const Janet *argv) { JanetCompiler *c = opts.compiler; int32_t labelr, labeljr, labeld, labeljd; JanetFopts condopts, bodyopts; JanetSlot cond, left, right, target; Janet truebody, falsebody; JanetScope condscope, tempscope; const int tail = opts.flags & JANET_FOPTS_TAIL; const int drop = opts.flags & JANET_FOPTS_DROP; uint8_t ifnjmp = JOP_JUMP_IF_NOT; if (argn < 2 || argn > 3) { janetc_cerror(c, "expected 2 or 3 arguments to if"); return janetc_cslot(janet_wrap_nil()); } /* Get the bodies of the if expression */ truebody = argv[1]; falsebody = argn > 2 ? argv[2] : janet_wrap_nil(); /* Get options */ condopts = janetc_fopts_default(c); bodyopts = opts; bodyopts.flags &= ~JANET_FOPTS_ACCEPT_SPLICE; /* Set target for compilation */ target = (drop || tail) ? janetc_cslot(janet_wrap_nil()) : janetc_gettarget(opts); /* Compile condition */ janetc_scope(&condscope, c, 0, "if"); Janet condform = argv[0]; if (janetc_check_nil_form(condform, &condform, JANET_FUN_EQ)) { ifnjmp = JOP_JUMP_IF_NOT_NIL; } else if (janetc_check_nil_form(condform, &condform, JANET_FUN_NEQ)) { ifnjmp = JOP_JUMP_IF_NIL; } cond = janetc_value(condopts, condform); /* Check constant condition. */ /* TODO: Use type info for more short circuits */ if (cond.flags & JANET_SLOT_CONSTANT) { int swap_condition = 0; if (ifnjmp == JOP_JUMP_IF_NOT && !janet_truthy(cond.constant)) swap_condition = 1; if (ifnjmp == JOP_JUMP_IF_NIL && janet_checktype(cond.constant, JANET_NIL)) swap_condition = 1; if (ifnjmp == JOP_JUMP_IF_NOT_NIL && !janet_checktype(cond.constant, JANET_NIL)) swap_condition = 1; if (swap_condition) { /* Swap the true and false bodies */ Janet temp = falsebody; falsebody = truebody; truebody = temp; } janetc_scope(&tempscope, c, 0, "if-true"); right = janetc_value(bodyopts, truebody); if (!drop && !tail) janetc_copy(c, target, right); janetc_popscope(c); if (!janet_checktype(falsebody, JANET_NIL)) { janetc_throwaway(bodyopts, falsebody); } janetc_popscope(c); return target; } /* Compile jump to right */ labeljr = janetc_emit_si(c, ifnjmp, cond, 0, 0); /* Condition left body */ janetc_scope(&tempscope, c, 0, "if-true"); left = janetc_value(bodyopts, truebody); if (!drop && !tail) janetc_copy(c, target, left); janetc_popscope(c); /* Compile jump to done */ labeljd = janet_v_count(c->buffer); if (!tail && !(drop && janet_checktype(falsebody, JANET_NIL))) janetc_emit(c, JOP_JUMP); /* Compile right body */ labelr = janet_v_count(c->buffer); janetc_scope(&tempscope, c, 0, "if-false"); right = janetc_value(bodyopts, falsebody); if (!drop && !tail) janetc_copy(c, target, right); janetc_popscope(c); /* Pop main scope */ janetc_popscope(c); /* Write jumps - only add jump lengths if jump actually emitted */ labeld = janet_v_count(c->buffer); if (labeljr < labeld) { c->buffer[labeljr] |= (labelr - labeljr) << 16; if (!tail && labeljd < labeld) c->buffer[labeljd] |= (labeld - labeljd) << 8; } if (tail) target.flags |= JANET_SLOT_RETURNED; return target; } /* Compile a do form. Do forms execute their body sequentially and * evaluate to the last expression in the body. */ static JanetSlot janetc_do(JanetFopts opts, int32_t argn, const Janet *argv) { int32_t i; JanetSlot ret = janetc_cslot(janet_wrap_nil()); JanetCompiler *c = opts.compiler; JanetFopts subopts = janetc_fopts_default(c); JanetScope tempscope; janetc_scope(&tempscope, c, 0, "do"); for (i = 0; i < argn; i++) { if (i != argn - 1) { subopts.flags = JANET_FOPTS_DROP; } else { subopts = opts; subopts.flags &= ~JANET_FOPTS_ACCEPT_SPLICE; } ret = janetc_value(subopts, argv[i]); if (i != argn - 1) { janetc_freeslot(c, ret); } } janetc_popscope_keepslot(c, ret); return ret; } /* Compile an upscope form. Upscope forms execute their body sequentially and * evaluate to the last expression in the body, but without lexical scope. */ static JanetSlot janetc_upscope(JanetFopts opts, int32_t argn, const Janet *argv) { int32_t i; JanetSlot ret = janetc_cslot(janet_wrap_nil()); JanetCompiler *c = opts.compiler; JanetFopts subopts = janetc_fopts_default(c); for (i = 0; i < argn; i++) { if (i != argn - 1) { subopts.flags = JANET_FOPTS_DROP; } else { subopts = opts; subopts.flags &= ~JANET_FOPTS_ACCEPT_SPLICE; } ret = janetc_value(subopts, argv[i]); if (i != argn - 1) { janetc_freeslot(c, ret); } } return ret; } /* Add a funcdef to the top most function scope */ static int32_t janetc_addfuncdef(JanetCompiler *c, JanetFuncDef *def) { JanetScope *scope = c->scope; while (scope) { if (scope->flags & JANET_SCOPE_FUNCTION) break; scope = scope->parent; } janet_assert(scope, "could not add funcdef"); janet_v_push(scope->defs, def); return janet_v_count(scope->defs) - 1; } /* * break * * jump :end or retn if in function */ static JanetSlot janetc_break(JanetFopts opts, int32_t argn, const Janet *argv) { JanetCompiler *c = opts.compiler; JanetScope *scope = c->scope; if (argn > 1) { janetc_cerror(c, "expected at most 1 argument"); return janetc_cslot(janet_wrap_nil()); } /* Find scope to break from */ while (scope) { if (scope->flags & (JANET_SCOPE_FUNCTION | JANET_SCOPE_WHILE)) break; scope = scope->parent; } if (NULL == scope) { janetc_cerror(c, "break must occur in while loop or closure"); return janetc_cslot(janet_wrap_nil()); } /* Emit code to break from that scope */ JanetFopts subopts = janetc_fopts_default(c); if (scope->flags & JANET_SCOPE_FUNCTION) { if (!(scope->flags & JANET_SCOPE_WHILE) && argn) { /* Closure body with return argument */ subopts.flags |= JANET_FOPTS_TAIL; janetc_value(subopts, argv[0]); return janetc_cslot(janet_wrap_nil()); } else { /* while loop IIFE or no argument */ if (argn) { subopts.flags |= JANET_FOPTS_DROP; janetc_value(subopts, argv[0]); } janetc_emit(c, JOP_RETURN_NIL); return janetc_cslot(janet_wrap_nil()); } } else { if (argn) { subopts.flags |= JANET_FOPTS_DROP; janetc_value(subopts, argv[0]); } /* Tag the instruction so the while special can turn it into a proper jump */ janetc_emit(c, 0x80 | JOP_JUMP); return janetc_cslot(janet_wrap_nil()); } } /* * :whiletop * ... * :condition * jump-if-not cond :done * ... * jump :whiletop * :done */ static JanetSlot janetc_while(JanetFopts opts, int32_t argn, const Janet *argv) { JanetCompiler *c = opts.compiler; JanetSlot cond; JanetFopts subopts = janetc_fopts_default(c); JanetScope tempscope; int32_t labelwt, labeld, labeljt, labelc, i; int infinite = 0; int is_nil_form = 0; int is_notnil_form = 0; uint8_t ifjmp = JOP_JUMP_IF; uint8_t ifnjmp = JOP_JUMP_IF_NOT; if (argn < 1) { janetc_cerror(c, "expected at least 1 argument to while"); return janetc_cslot(janet_wrap_nil()); } labelwt = janet_v_count(c->buffer); janetc_scope(&tempscope, c, JANET_SCOPE_WHILE, "while"); /* Check for `(= nil _)` or `(not= nil _)` in condition, and if so, use the * jmpnl or jmpnn instructions. This let's us implement `(each ...)` * more efficiently. */ Janet condform = argv[0]; if (janetc_check_nil_form(condform, &condform, JANET_FUN_EQ)) { is_nil_form = 1; ifjmp = JOP_JUMP_IF_NIL; ifnjmp = JOP_JUMP_IF_NOT_NIL; } if (janetc_check_nil_form(condform, &condform, JANET_FUN_NEQ)) { is_notnil_form = 1; ifjmp = JOP_JUMP_IF_NOT_NIL; ifnjmp = JOP_JUMP_IF_NIL; } /* Compile condition */ cond = janetc_value(subopts, condform); /* Check for constant condition */ if (cond.flags & JANET_SLOT_CONSTANT) { /* Loop never executes */ int never_executes = is_nil_form ? !janet_checktype(cond.constant, JANET_NIL) : is_notnil_form ? janet_checktype(cond.constant, JANET_NIL) : !janet_truthy(cond.constant); if (never_executes) { janetc_popscope(c); return janetc_cslot(janet_wrap_nil()); } /* Infinite loop */ infinite = 1; } /* Infinite loop does not need to check condition */ labelc = infinite ? 0 : janetc_emit_si(c, ifnjmp, cond, 0, 0); /* Compile body */ for (i = 1; i < argn; i++) { subopts.flags = JANET_FOPTS_DROP; janetc_freeslot(c, janetc_value(subopts, argv[i])); } /* Check if closure created in while scope. If so, * recompile in a function scope. */ if (tempscope.flags & JANET_SCOPE_CLOSURE) { subopts = janetc_fopts_default(c); tempscope.flags |= JANET_SCOPE_UNUSED; janetc_popscope(c); if (c->buffer) janet_v__cnt(c->buffer) = labelwt; if (c->mapbuffer) janet_v__cnt(c->mapbuffer) = labelwt; janetc_scope(&tempscope, c, JANET_SCOPE_FUNCTION, "while-iife"); /* Recompile in the function scope */ cond = janetc_value(subopts, condform); if (!(cond.flags & JANET_SLOT_CONSTANT)) { /* If not an infinite loop, return nil when condition false */ janetc_emit_si(c, ifjmp, cond, 2, 0); janetc_emit(c, JOP_RETURN_NIL); } for (i = 1; i < argn; i++) { subopts.flags = JANET_FOPTS_DROP; janetc_freeslot(c, janetc_value(subopts, argv[i])); } /* But now add tail recursion */ int32_t tempself = janetc_regalloc_temp(&tempscope.ra, JANETC_REGTEMP_0); janetc_emit(c, JOP_LOAD_SELF | (tempself << 8)); janetc_emit(c, JOP_TAILCALL | (tempself << 8)); janetc_regalloc_freetemp(&c->scope->ra, tempself, JANETC_REGTEMP_0); /* Compile function */ JanetFuncDef *def = janetc_pop_funcdef(c); def->name = janet_cstring("while"); janet_def_addflags(def); int32_t defindex = janetc_addfuncdef(c, def); /* And then load the closure and call it. */ int32_t cloreg = janetc_regalloc_temp(&c->scope->ra, JANETC_REGTEMP_0); janetc_emit(c, JOP_CLOSURE | (cloreg << 8) | (defindex << 16)); janetc_emit(c, JOP_CALL | (cloreg << 8) | (cloreg << 16)); janetc_regalloc_freetemp(&c->scope->ra, cloreg, JANETC_REGTEMP_0); c->scope->flags |= JANET_SCOPE_CLOSURE; return janetc_cslot(janet_wrap_nil()); } /* Compile jump to :whiletop */ labeljt = janet_v_count(c->buffer); janetc_emit(c, JOP_JUMP); /* Calculate jumps */ labeld = janet_v_count(c->buffer); if (!infinite) c->buffer[labelc] |= (uint32_t)(labeld - labelc) << 16; c->buffer[labeljt] |= (uint32_t)(labelwt - labeljt) << 8; /* Calculate breaks */ for (int32_t i = labelwt; i < labeld; i++) { if (c->buffer[i] == (0x80 | JOP_JUMP)) { c->buffer[i] = JOP_JUMP | ((labeld - i) << 8); } } /* Pop scope and return nil slot */ janetc_popscope(c); return janetc_cslot(janet_wrap_nil()); } static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) { JanetCompiler *c = opts.compiler; JanetFuncDef *def; JanetSlot ret; Janet head; JanetScope fnscope; int32_t paramcount, argi, parami, arity, min_arity = 0, max_arity, defindex, i; JanetFopts subopts = janetc_fopts_default(c); const Janet *params; const char *errmsg = NULL; /* Function flags */ int vararg = 0; int structarg = 0; int allow_extra = 0; int selfref = 0; int hasname = 0; int seenamp = 0; int seenopt = 0; int namedargs = 0; /* Begin function */ c->scope->flags |= JANET_SCOPE_CLOSURE; janetc_scope(&fnscope, c, JANET_SCOPE_FUNCTION, "function"); if (argn == 0) { errmsg = "expected at least 1 argument to function literal"; goto error; } /* Read function parameters */ parami = 0; head = argv[0]; if (janet_checktype(head, JANET_SYMBOL)) { selfref = 1; hasname = 1; parami = 1; } else if (janet_checktype(head, JANET_KEYWORD)) { hasname = 1; parami = 1; } if (parami >= argn || !janet_checktype(argv[parami], JANET_TUPLE)) { errmsg = "expected function parameters"; goto error; } /* Keep track of destructured parameters */ JanetSlot *destructed_params = NULL; JanetSlot *named_params = NULL; JanetTable *named_table = NULL; JanetSlot named_slot; /* Compile function parameters */ params = janet_unwrap_tuple(argv[parami]); paramcount = janet_tuple_length(params); arity = paramcount; for (i = 0; i < paramcount; i++) { Janet param = params[i]; if (namedargs) { arity--; if (!janet_checktype(param, JANET_SYMBOL)) { errmsg = "only named arguments can follow &named"; goto error; } Janet key = janet_wrap_keyword(janet_unwrap_symbol(param)); janet_table_put(named_table, key, param); janet_v_push(named_params, janetc_farslot(c)); } else if (janet_checktype(param, JANET_SYMBOL)) { /* Check for varargs and unfixed arity */ const uint8_t *sym = janet_unwrap_symbol(param); if (sym[0] == '&') { if (!janet_cstrcmp(sym, "&")) { if (seenamp) { errmsg = "& in unexpected location"; goto error; } else if (i == paramcount - 1) { allow_extra = 1; arity--; } else if (i == paramcount - 2) { vararg = 1; arity -= 2; } else { errmsg = "& in unexpected location"; goto error; } seenamp = 1; } else if (!janet_cstrcmp(sym, "&opt")) { if (seenopt) { errmsg = "only one &opt allowed"; goto error; } else if (i == paramcount - 1) { errmsg = "&opt cannot be last item in parameter list"; goto error; } min_arity = i; arity--; seenopt = 1; } else if (!janet_cstrcmp(sym, "&keys")) { if (seenamp) { errmsg = "&keys in unexpected location"; goto error; } else if (i == paramcount - 2) { vararg = 1; structarg = 1; arity -= 2; } else { errmsg = "&keys in unexpected location"; goto error; } seenamp = 1; } else if (!janet_cstrcmp(sym, "&named")) { if (seenamp) { errmsg = "&named in unexpected location"; goto error; } vararg = 1; structarg = 1; arity--; seenamp = 1; namedargs = 1; named_table = janet_table(10); named_slot = janetc_farslot(c); } else { janetc_nameslot(c, sym, janetc_farslot(c)); } } else { janetc_nameslot(c, sym, janetc_farslot(c)); } } else { janet_v_push(destructed_params, janetc_farslot(c)); } } /* Compile named arguments */ if (namedargs) { Janet param = janet_wrap_table(named_table); destructure(c, param, named_slot, defleaf, NULL); janetc_freeslot(c, named_slot); janet_v_free(named_params); } /* Compile destructed params */ int32_t j = 0; for (i = 0; i < paramcount; i++) { Janet param = params[i]; if (!janet_checktype(param, JANET_SYMBOL)) { janet_assert(janet_v_count(destructed_params) > j, "out of bounds"); JanetSlot reg = destructed_params[j++]; destructure(c, param, reg, defleaf, NULL); janetc_freeslot(c, reg); } } janet_v_free(destructed_params); max_arity = (vararg || allow_extra) ? INT32_MAX : arity; if (!seenopt) min_arity = arity; /* Check for self ref (also avoid if arguments shadow own name) */ if (selfref) { /* Check if the parameters shadow the function name. If so, don't * emit JOP_LOAD_SELF and add a binding since that most users * seem to expect that function parameters take precedence over the * function name */ const uint8_t *sym = janet_unwrap_symbol(head); int32_t len = janet_v_count(c->scope->syms); int found = 0; for (int32_t i = 0; i < len; i++) { if (c->scope->syms[i].sym == sym) { found = 1; } } if (!found) { JanetSlot slot = janetc_farslot(c); slot.flags = JANET_SLOT_NAMED | JANET_FUNCTION; janetc_emit_s(c, JOP_LOAD_SELF, slot, 1); janetc_nameslot_no_unused(c, sym, slot); } } /* Compile function body */ if (parami + 1 == argn) { janetc_emit(c, JOP_RETURN_NIL); } else { for (argi = parami + 1; argi < argn; argi++) { subopts.flags = (argi == (argn - 1)) ? JANET_FOPTS_TAIL : JANET_FOPTS_DROP; janetc_value(subopts, argv[argi]); if (c->result.status == JANET_COMPILE_ERROR) goto error2; } } /* Build function */ def = janetc_pop_funcdef(c); def->arity = arity; def->min_arity = min_arity; def->max_arity = max_arity; if (named_table != NULL) { def->named_args_count = named_table->count; } if (vararg) def->flags |= JANET_FUNCDEF_FLAG_VARARG; if (structarg) def->flags |= JANET_FUNCDEF_FLAG_STRUCTARG; if (namedargs) def->flags |= JANET_FUNCDEF_FLAG_NAMEDARGS; if (hasname) def->name = janet_unwrap_symbol(head); /* Also correctly unwraps keyword */ janet_def_addflags(def); defindex = janetc_addfuncdef(c, def); /* Ensure enough slots for vararg function. */ if (arity + vararg > def->slotcount) def->slotcount = arity + vararg; /* Instantiate closure */ ret = janetc_gettarget(opts); janetc_emit_su(c, JOP_CLOSURE, ret, defindex, 1); return ret; error: janetc_cerror(c, errmsg); error2: janetc_popscope(c); return janetc_cslot(janet_wrap_nil()); } /* Keep in lexicographic order */ static const JanetSpecial janetc_specials[] = { {"break", janetc_break}, {"def", janetc_def}, {"do", janetc_do}, {"fn", janetc_fn}, {"if", janetc_if}, {"quasiquote", janetc_quasiquote}, {"quote", janetc_quote}, {"set", janetc_varset}, {"splice", janetc_splice}, {"unquote", janetc_unquote}, {"upscope", janetc_upscope}, {"var", janetc_var}, {"while", janetc_while} }; /* Find a special */ const JanetSpecial *janetc_special(const uint8_t *name) { return janet_strbinsearch( &janetc_specials, sizeof(janetc_specials) / sizeof(JanetSpecial), sizeof(JanetSpecial), name); } janet-1.41.2/src/core/state.c000066400000000000000000000041001514534607600157110ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "state.h" #include "util.h" #endif #ifdef JANET_WINDOWS #include #endif JANET_THREAD_LOCAL JanetVM janet_vm; JanetVM *janet_local_vm(void) { return &janet_vm; } JanetVM *janet_vm_alloc(void) { JanetVM *mem = janet_malloc(sizeof(JanetVM)); if (NULL == mem) { JANET_OUT_OF_MEMORY; } return mem; } void janet_vm_free(JanetVM *vm) { janet_free(vm); } void janet_vm_save(JanetVM *into) { *into = janet_vm; } void janet_vm_load(JanetVM *from) { janet_vm = *from; } /* Trigger suspension of the Janet vm by trying to * exit the interpreter loop when convenient. You can optionally * use NULL to interrupt the current VM when convenient */ void janet_interpreter_interrupt(JanetVM *vm) { vm = vm ? vm : &janet_vm; janet_atomic_inc(&vm->auto_suspend); } void janet_interpreter_interrupt_handled(JanetVM *vm) { vm = vm ? vm : &janet_vm; janet_atomic_dec(&vm->auto_suspend); } janet-1.41.2/src/core/state.h000066400000000000000000000132471514534607600157320ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_STATE_H_defined #define JANET_STATE_H_defined #ifndef JANET_AMALG #include "features.h" #include #include #endif #ifdef JANET_EV #ifdef JANET_WINDOWS #include #else #include #endif #endif typedef int64_t JanetTimestamp; typedef struct JanetScratch { JanetScratchFinalizer finalize; long long mem[]; /* for proper alignment */ } JanetScratch; typedef struct { JanetGCObject *self; JanetGCObject *other; int32_t index; int32_t index2; } JanetTraversalNode; typedef struct { int32_t capacity; int32_t head; int32_t tail; void *data; } JanetQueue; #ifdef JANET_EV typedef struct { JanetTimestamp when; JanetFiber *fiber; JanetFiber *curr_fiber; uint32_t sched_id; int is_error; int has_worker; #ifdef JANET_WINDOWS HANDLE worker; HANDLE worker_event; #else pthread_t worker; #endif } JanetTimeout; #endif /* Registry table for C functions - contains metadata that can * be looked up by cfunction pointer. All strings here are pointing to * static memory not managed by Janet. */ typedef struct { JanetCFunction cfun; const char *name; const char *name_prefix; const char *source_file; int32_t source_line; /* int32_t min_arity; */ /* int32_t max_arity; */ } JanetCFunRegistry; struct JanetVM { /* Place for user data */ void *user; /* Top level dynamic bindings */ JanetTable *top_dyns; /* Cache the core environment */ JanetTable *core_env; /* How many VM stacks have been entered */ int stackn; /* If this flag is true, suspend on function calls and backwards jumps. * When this occurs, this flag will be reset to 0. */ volatile JanetAtomicInt auto_suspend; /* The current running fiber on the current thread. * Set and unset by functions in vm.c */ JanetFiber *fiber; JanetFiber *root_fiber; /* The current pointer to the inner most jmp_buf. The current * return point for panics. */ jmp_buf *signal_buf; Janet *return_reg; int coerce_error; /* The global registry for c functions. Used to store meta-data * along with otherwise bare c function pointers. */ JanetCFunRegistry *registry; size_t registry_cap; size_t registry_count; int registry_dirty; /* Registry for abstract types that can be marshalled. * We need this to look up the constructors when unmarshalling. */ JanetTable *abstract_registry; /* Immutable value cache */ const uint8_t **cache; uint32_t cache_capacity; uint32_t cache_count; uint32_t cache_deleted; uint8_t gensym_counter[8]; /* Garbage collection */ void *blocks; void *weak_blocks; size_t gc_interval; size_t next_collection; size_t block_count; int gc_suspend; int gc_mark_phase; /* GC roots */ Janet *roots; size_t root_count; size_t root_capacity; /* Scratch memory */ JanetScratch **scratch_mem; size_t scratch_cap; size_t scratch_len; /* Sandbox flags */ uint32_t sandbox_flags; /* Random number generator */ JanetRNG rng; /* Traversal pointers */ JanetTraversalNode *traversal; JanetTraversalNode *traversal_top; JanetTraversalNode *traversal_base; /* Thread safe strerror error buffer - for janet_strerror */ #ifndef JANET_WINDOWS char strerror_buf[256]; #endif /* Event loop and scheduler globals */ #ifdef JANET_EV size_t tq_count; size_t tq_capacity; JanetQueue spawn; JanetTimeout *tq; JanetRNG ev_rng; volatile JanetAtomicInt listener_count; /* used in signal handler, must be volatile */ JanetTable threaded_abstracts; /* All abstract types that can be shared between threads (used in this thread) */ JanetTable active_tasks; /* All possibly live task fibers - used just for tracking */ JanetTable signal_handlers; #ifdef JANET_WINDOWS void **iocp; #elif defined(JANET_EV_EPOLL) pthread_attr_t new_thread_attr; JanetHandle selfpipe[2]; int epoll; int timerfd; int timer_enabled; #elif defined(JANET_EV_KQUEUE) pthread_attr_t new_thread_attr; JanetHandle selfpipe[2]; int kq; int timer; int timer_enabled; #else JanetStream **streams; size_t stream_count; size_t stream_capacity; pthread_attr_t new_thread_attr; JanetHandle selfpipe[2]; struct pollfd *fds; #endif #endif }; extern JANET_THREAD_LOCAL JanetVM janet_vm; #ifdef JANET_NET void janet_net_init(void); void janet_net_deinit(void); #endif #ifdef JANET_EV void janet_ev_init(void); void janet_ev_deinit(void); #endif #endif /* JANET_STATE_H_defined */ janet-1.41.2/src/core/string.c000066400000000000000000000615521514534607600161150ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "gc.h" #include "util.h" #include "state.h" #endif #include /* Begin building a string */ uint8_t *janet_string_begin(int32_t length) { JanetStringHead *head = janet_gcalloc(JANET_MEMORY_STRING, sizeof(JanetStringHead) + (size_t) length + 1); head->length = length; uint8_t *data = (uint8_t *)head->data; data[length] = 0; return data; } /* Finish building a string */ const uint8_t *janet_string_end(uint8_t *str) { janet_string_hash(str) = janet_string_calchash(str, janet_string_length(str)); return str; } /* Load a buffer as a string */ const uint8_t *janet_string(const uint8_t *buf, int32_t len) { JanetStringHead *head = janet_gcalloc(JANET_MEMORY_STRING, sizeof(JanetStringHead) + (size_t) len + 1); head->length = len; head->hash = janet_string_calchash(buf, len); uint8_t *data = (uint8_t *)head->data; safe_memcpy(data, buf, len); data[len] = 0; return data; } /* Compare two strings */ int janet_string_compare(const uint8_t *lhs, const uint8_t *rhs) { int32_t xlen = janet_string_length(lhs); int32_t ylen = janet_string_length(rhs); int32_t len = xlen > ylen ? ylen : xlen; int res = memcmp(lhs, rhs, len); if (res) return res > 0 ? 1 : -1; if (xlen == ylen) return 0; return xlen < ylen ? -1 : 1; } /* Compare a janet string with a piece of memory */ int janet_string_equalconst(const uint8_t *lhs, const uint8_t *rhs, int32_t rlen, int32_t rhash) { int32_t lhash = janet_string_hash(lhs); int32_t llen = janet_string_length(lhs); if (lhash != rhash || llen != rlen) return 0; if (lhs == rhs) return 1; return !memcmp(lhs, rhs, rlen); } /* Check if two strings are equal */ int janet_string_equal(const uint8_t *lhs, const uint8_t *rhs) { return janet_string_equalconst(lhs, rhs, janet_string_length(rhs), janet_string_hash(rhs)); } /* Load a c string */ const uint8_t *janet_cstring(const char *str) { return janet_string((const uint8_t *)str, (int32_t)strlen(str)); } /* Knuth Morris Pratt Algorithm */ struct kmp_state { int32_t i; int32_t j; int32_t textlen; int32_t patlen; int32_t *lookup; const uint8_t *text; const uint8_t *pat; }; static void kmp_init( struct kmp_state *s, const uint8_t *text, int32_t textlen, const uint8_t *pat, int32_t patlen) { if (patlen == 0) { janet_panic("expected non-empty pattern"); } int32_t *lookup = janet_calloc(patlen, sizeof(int32_t)); if (!lookup) { JANET_OUT_OF_MEMORY; } s->lookup = lookup; s->i = 0; s->j = 0; s->text = text; s->pat = pat; s->textlen = textlen; s->patlen = patlen; /* Init state machine */ { int32_t i, j; for (i = 1, j = 0; i < patlen; i++) { while (j && pat[j] != pat[i]) j = lookup[j - 1]; if (pat[j] == pat[i]) j++; lookup[i] = j; } } } static void kmp_deinit(struct kmp_state *state) { janet_free(state->lookup); } static void kmp_seti(struct kmp_state *state, int32_t i) { state->i = i; state->j = 0; } static int32_t kmp_next(struct kmp_state *state) { int32_t i = state->i; int32_t j = state->j; int32_t textlen = state->textlen; int32_t patlen = state->patlen; const uint8_t *text = state->text; const uint8_t *pat = state->pat; int32_t *lookup = state->lookup; while (i < textlen) { if (text[i] == pat[j]) { if (j == patlen - 1) { state->i = i + 1; state->j = lookup[j]; return i - j; } else { i++; j++; } } else { if (j > 0) { j = lookup[j - 1]; } else { i++; } } } return -1; } /* CFuns */ JANET_CORE_FN(cfun_string_slice, "(string/slice bytes &opt start end)", "Returns a substring from a byte sequence. The substring is from " "index `start` inclusive to index `end`, exclusive. All indexing " "is from 0. `start` and `end` can also be negative to indicate indexing " "from the end of the string. Note that if `start` is negative it is " "exclusive, and if `end` is negative it is inclusive, to allow a full " "negative slice range.") { JanetByteView view = janet_getbytes(argv, 0); JanetRange range = janet_getslice(argc, argv); return janet_stringv(view.bytes + range.start, range.end - range.start); } JANET_CORE_FN(cfun_symbol_slice, "(symbol/slice bytes &opt start end)", "Same as string/slice, but returns a symbol.") { JanetByteView view = janet_getbytes(argv, 0); JanetRange range = janet_getslice(argc, argv); return janet_symbolv(view.bytes + range.start, range.end - range.start); } JANET_CORE_FN(cfun_keyword_slice, "(keyword/slice bytes &opt start end)", "Same as string/slice, but returns a keyword.") { JanetByteView view = janet_getbytes(argv, 0); JanetRange range = janet_getslice(argc, argv); return janet_keywordv(view.bytes + range.start, range.end - range.start); } JANET_CORE_FN(cfun_string_repeat, "(string/repeat bytes n)", "Returns a string that is `n` copies of `bytes` concatenated.") { janet_fixarity(argc, 2); JanetByteView view = janet_getbytes(argv, 0); int32_t rep = janet_getinteger(argv, 1); if (rep < 0) janet_panic("expected non-negative number of repetitions"); if (rep == 0) return janet_cstringv(""); int64_t mulres = (int64_t) rep * view.len; if (mulres > INT32_MAX) janet_panic("result string is too long"); uint8_t *newbuf = janet_string_begin((int32_t) mulres); uint8_t *end = newbuf + mulres; for (uint8_t *p = newbuf; p < end; p += view.len) { safe_memcpy(p, view.bytes, view.len); } return janet_wrap_string(janet_string_end(newbuf)); } JANET_CORE_FN(cfun_string_bytes, "(string/bytes str)", "Returns a tuple of integers that are the byte values of the string.") { janet_fixarity(argc, 1); JanetByteView view = janet_getbytes(argv, 0); Janet *tup = janet_tuple_begin(view.len); int32_t i; for (i = 0; i < view.len; i++) { tup[i] = janet_wrap_integer((int32_t) view.bytes[i]); } return janet_wrap_tuple(janet_tuple_end(tup)); } JANET_CORE_FN(cfun_string_frombytes, "(string/from-bytes & byte-vals)", "Creates a string from integer parameters with byte values. All integers " "will be coerced to the range of 1 byte 0-255.") { int32_t i; uint8_t *buf = janet_string_begin(argc); for (i = 0; i < argc; i++) { int32_t c = janet_getinteger(argv, i); buf[i] = c & 0xFF; } return janet_wrap_string(janet_string_end(buf)); } JANET_CORE_FN(cfun_string_asciilower, "(string/ascii-lower str)", "Returns a new string where all bytes are replaced with the " "lowercase version of themselves in ASCII. Does only a very simple " "case check, meaning no unicode support.") { janet_fixarity(argc, 1); JanetByteView view = janet_getbytes(argv, 0); uint8_t *buf = janet_string_begin(view.len); for (int32_t i = 0; i < view.len; i++) { uint8_t c = view.bytes[i]; if (c >= 65 && c <= 90) { buf[i] = c + 32; } else { buf[i] = c; } } return janet_wrap_string(janet_string_end(buf)); } JANET_CORE_FN(cfun_string_asciiupper, "(string/ascii-upper str)", "Returns a new string where all bytes are replaced with the " "uppercase version of themselves in ASCII. Does only a very simple " "case check, meaning no unicode support.") { janet_fixarity(argc, 1); JanetByteView view = janet_getbytes(argv, 0); uint8_t *buf = janet_string_begin(view.len); for (int32_t i = 0; i < view.len; i++) { uint8_t c = view.bytes[i]; if (c >= 97 && c <= 122) { buf[i] = c - 32; } else { buf[i] = c; } } return janet_wrap_string(janet_string_end(buf)); } JANET_CORE_FN(cfun_string_reverse, "(string/reverse str)", "Returns a string that is the reversed version of `str`.") { janet_fixarity(argc, 1); JanetByteView view = janet_getbytes(argv, 0); uint8_t *buf = janet_string_begin(view.len); int32_t i, j; for (i = 0, j = view.len - 1; i < view.len; i++, j--) { buf[i] = view.bytes[j]; } return janet_wrap_string(janet_string_end(buf)); } static void findsetup(int32_t argc, Janet *argv, struct kmp_state *s, int32_t extra) { janet_arity(argc, 2, 3 + extra); JanetByteView pat = janet_getbytes(argv, 0); JanetByteView text = janet_getbytes(argv, 1); int32_t start = 0; if (argc >= 3) { start = janet_getinteger(argv, 2); if (start < 0) janet_panic("expected non-negative start index"); } kmp_init(s, text.bytes, text.len, pat.bytes, pat.len); s->i = start; } JANET_CORE_FN(cfun_string_find, "(string/find patt str &opt start-index)", "Searches for the first instance of pattern `patt` in string " "`str`. Returns the index of the first character in `patt` if found, " "otherwise returns nil.") { int32_t result; struct kmp_state state; findsetup(argc, argv, &state, 0); result = kmp_next(&state); kmp_deinit(&state); return result < 0 ? janet_wrap_nil() : janet_wrap_integer(result); } JANET_CORE_FN(cfun_string_hasprefix, "(string/has-prefix? pfx str)", "Tests whether `str` starts with `pfx`.") { janet_fixarity(argc, 2); JanetByteView prefix = janet_getbytes(argv, 0); JanetByteView str = janet_getbytes(argv, 1); return str.len < prefix.len ? janet_wrap_false() : janet_wrap_boolean(memcmp(prefix.bytes, str.bytes, prefix.len) == 0); } JANET_CORE_FN(cfun_string_hassuffix, "(string/has-suffix? sfx str)", "Tests whether `str` ends with `sfx`.") { janet_fixarity(argc, 2); JanetByteView suffix = janet_getbytes(argv, 0); JanetByteView str = janet_getbytes(argv, 1); return str.len < suffix.len ? janet_wrap_false() : janet_wrap_boolean(memcmp(suffix.bytes, str.bytes + str.len - suffix.len, suffix.len) == 0); } JANET_CORE_FN(cfun_string_findall, "(string/find-all patt str &opt start-index)", "Searches for all instances of pattern `patt` in string " "`str`. Returns an array of all indices of found patterns. Overlapping " "instances of the pattern are counted individually, meaning a byte in `str` " "may contribute to multiple found patterns.") { int32_t result; struct kmp_state state; findsetup(argc, argv, &state, 0); JanetArray *array = janet_array(0); while ((result = kmp_next(&state)) >= 0) { janet_array_push(array, janet_wrap_integer(result)); } kmp_deinit(&state); return janet_wrap_array(array); } struct replace_state { struct kmp_state kmp; Janet subst; }; static void replacesetup(int32_t argc, Janet *argv, struct replace_state *s) { janet_arity(argc, 3, 4); JanetByteView pat = janet_getbytes(argv, 0); Janet subst = argv[1]; JanetByteView text = janet_getbytes(argv, 2); int32_t start = 0; if (argc == 4) { start = janet_getinteger(argv, 3); if (start < 0) janet_panic("expected non-negative start index"); } kmp_init(&s->kmp, text.bytes, text.len, pat.bytes, pat.len); s->kmp.i = start; s->subst = subst; } JANET_CORE_FN(cfun_string_replace, "(string/replace patt subst str)", "Replace the first occurrence of `patt` with `subst` in the string `str`. " "If `subst` is a function, it will be called with `patt` only if a match is found, " "and should return the actual replacement text to use. " "Will return the new string if `patt` is found, otherwise returns `str`.") { int32_t result; struct replace_state s; uint8_t *buf; replacesetup(argc, argv, &s); result = kmp_next(&s.kmp); if (result < 0) { kmp_deinit(&s.kmp); return janet_stringv(s.kmp.text, s.kmp.textlen); } JanetByteView subst = janet_text_substitution(&s.subst, s.kmp.text + result, s.kmp.patlen, NULL); buf = janet_string_begin(s.kmp.textlen - s.kmp.patlen + subst.len); safe_memcpy(buf, s.kmp.text, result); safe_memcpy(buf + result, subst.bytes, subst.len); safe_memcpy(buf + result + subst.len, s.kmp.text + result + s.kmp.patlen, s.kmp.textlen - result - s.kmp.patlen); kmp_deinit(&s.kmp); return janet_wrap_string(janet_string_end(buf)); } JANET_CORE_FN(cfun_string_replaceall, "(string/replace-all patt subst str)", "Replace all instances of `patt` with `subst` in the string `str`. Overlapping " "matches will not be counted, only the first match in such a span will be replaced. " "If `subst` is a function, it will be called with `patt` once for each match, " "and should return the actual replacement text to use. " "Will return the new string if `patt` is found, otherwise returns `str`.") { int32_t result; struct replace_state s; JanetBuffer b; int32_t lastindex = 0; replacesetup(argc, argv, &s); janet_buffer_init(&b, s.kmp.textlen); while ((result = kmp_next(&s.kmp)) >= 0) { JanetByteView subst = janet_text_substitution(&s.subst, s.kmp.text + result, s.kmp.patlen, NULL); janet_buffer_push_bytes(&b, s.kmp.text + lastindex, result - lastindex); janet_buffer_push_bytes(&b, subst.bytes, subst.len); lastindex = result + s.kmp.patlen; kmp_seti(&s.kmp, lastindex); } janet_buffer_push_bytes(&b, s.kmp.text + lastindex, s.kmp.textlen - lastindex); const uint8_t *ret = janet_string(b.data, b.count); janet_buffer_deinit(&b); kmp_deinit(&s.kmp); return janet_wrap_string(ret); } JANET_CORE_FN(cfun_string_split, "(string/split delim str &opt start limit)", "Splits a string `str` with delimiter `delim` and returns an array of " "substrings. The substrings will not contain the delimiter `delim`. If `delim` " "is not found, the returned array will have one element. Will start searching " "for `delim` at the index `start` (if provided), and return up to a maximum " "of `limit` results (if provided).") { int32_t result; JanetArray *array; struct kmp_state state; int32_t limit = -1, lastindex = 0; if (argc == 4) { limit = janet_getinteger(argv, 3); } findsetup(argc, argv, &state, 1); array = janet_array(0); while ((result = kmp_next(&state)) >= 0 && --limit) { const uint8_t *slice = janet_string(state.text + lastindex, result - lastindex); janet_array_push(array, janet_wrap_string(slice)); lastindex = result + state.patlen; kmp_seti(&state, lastindex); } const uint8_t *slice = janet_string(state.text + lastindex, state.textlen - lastindex); janet_array_push(array, janet_wrap_string(slice)); kmp_deinit(&state); return janet_wrap_array(array); } JANET_CORE_FN(cfun_string_checkset, "(string/check-set set str)", "Checks that the string `str` only contains bytes that appear in the string `set`. " "Returns true if all bytes in `str` appear in `set`, false if some bytes in `str` do " "not appear in `set`.") { uint32_t bitset[8] = {0, 0, 0, 0, 0, 0, 0, 0}; janet_fixarity(argc, 2); JanetByteView set = janet_getbytes(argv, 0); JanetByteView str = janet_getbytes(argv, 1); /* Populate set */ for (int32_t i = 0; i < set.len; i++) { int index = set.bytes[i] >> 5; uint32_t mask = 1 << (set.bytes[i] & 0x1F); bitset[index] |= mask; } /* Check set */ for (int32_t i = 0; i < str.len; i++) { int index = str.bytes[i] >> 5; uint32_t mask = 1 << (str.bytes[i] & 0x1F); if (!(bitset[index] & mask)) { return janet_wrap_false(); } } return janet_wrap_true(); } JANET_CORE_FN(cfun_string_join, "(string/join parts &opt sep)", "Joins an array of strings into one string, optionally separated by " "a separator string `sep`.") { janet_arity(argc, 1, 2); JanetView parts = janet_getindexed(argv, 0); JanetByteView joiner; if (argc == 2) { joiner = janet_getbytes(argv, 1); } else { joiner.bytes = NULL; joiner.len = 0; } /* Check args */ int32_t i; int64_t finallen = 0; for (i = 0; i < parts.len; i++) { const uint8_t *chunk; int32_t chunklen = 0; if (!janet_bytes_view(parts.items[i], &chunk, &chunklen)) { janet_panicf("item %d of parts is not a byte sequence, got %v", i, parts.items[i]); } if (i) finallen += joiner.len; finallen += chunklen; if (finallen > INT32_MAX) janet_panic("result string too long"); } uint8_t *buf, *out; out = buf = janet_string_begin((int32_t) finallen); for (i = 0; i < parts.len; i++) { const uint8_t *chunk = NULL; int32_t chunklen = 0; if (i) { safe_memcpy(out, joiner.bytes, joiner.len); out += joiner.len; } janet_bytes_view(parts.items[i], &chunk, &chunklen); safe_memcpy(out, chunk, chunklen); out += chunklen; } return janet_wrap_string(janet_string_end(buf)); } JANET_CORE_FN(cfun_string_format, "(string/format format & values)", "Similar to C's `snprintf`, but specialized for operating with Janet values. Returns " "a new string.\n\n" "The following conversion specifiers are supported, where the upper case specifiers generate " "upper case output:\n" "- `c`: ASCII character.\n" "- `d`, `i`: integer, formatted as a decimal number.\n" "- `x`, `X`: integer, formatted as a hexadecimal number.\n" "- `o`: integer, formatted as an octal number.\n" "- `f`, `F`: floating point number, formatted as a decimal number.\n" "- `e`, `E`: floating point number, formatted in scientific notation.\n" "- `g`, `G`: floating point number, formatted in its shortest form.\n" "- `a`, `A`: floating point number, formatted as a hexadecimal number.\n" "- `s`: formatted as a string, precision indicates padding and maximum length.\n" "- `t`: emit the type of the given value.\n" "- `v`: format with (describe x)\n" "- `V`: format with (string x)\n" "- `j`: format to jdn (Janet data notation).\n" "\n" "The following conversion specifiers are used for \"pretty-printing\", where the upper-case " "variants generate colored output. These specifiers can take a precision " "argument to specify the maximum nesting depth to print.\n" "- `p`, `P`: pretty format, truncating if necessary\n" "- `m`, `M`: pretty format without truncating.\n" "- `q`, `Q`: pretty format on one line, truncating if necessary.\n" "- `n`, `N`: pretty format on one line without truncation.\n") { janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_buffer(0); const char *strfrmt = (const char *) janet_getstring(argv, 0); janet_buffer_format(buffer, strfrmt, 0, argc, argv); return janet_stringv(buffer->data, buffer->count); } static int trim_help_checkset(JanetByteView set, uint8_t x) { for (int32_t j = 0; j < set.len; j++) if (set.bytes[j] == x) return 1; return 0; } static int32_t trim_help_leftedge(JanetByteView str, JanetByteView set) { for (int32_t i = 0; i < str.len; i++) if (!trim_help_checkset(set, str.bytes[i])) return i; return str.len; } static int32_t trim_help_rightedge(JanetByteView str, JanetByteView set) { for (int32_t i = str.len - 1; i >= 0; i--) if (!trim_help_checkset(set, str.bytes[i])) return i + 1; return 0; } static void trim_help_args(int32_t argc, Janet *argv, JanetByteView *str, JanetByteView *set) { janet_arity(argc, 1, 2); *str = janet_getbytes(argv, 0); if (argc >= 2) { *set = janet_getbytes(argv, 1); } else { set->bytes = (const uint8_t *)(" \t\r\n\v\f"); set->len = 6; } } JANET_CORE_FN(cfun_string_trim, "(string/trim str &opt set)", "Trim leading and trailing whitespace from a byte sequence. If the argument " "`set` is provided, consider only characters in `set` to be whitespace.") { JanetByteView str, set; trim_help_args(argc, argv, &str, &set); int32_t left_edge = trim_help_leftedge(str, set); int32_t right_edge = trim_help_rightedge(str, set); if (right_edge < left_edge) return janet_stringv(NULL, 0); return janet_stringv(str.bytes + left_edge, right_edge - left_edge); } JANET_CORE_FN(cfun_string_triml, "(string/triml str &opt set)", "Trim leading whitespace from a byte sequence. If the argument " "`set` is provided, consider only characters in `set` to be whitespace.") { JanetByteView str, set; trim_help_args(argc, argv, &str, &set); int32_t left_edge = trim_help_leftedge(str, set); return janet_stringv(str.bytes + left_edge, str.len - left_edge); } JANET_CORE_FN(cfun_string_trimr, "(string/trimr str &opt set)", "Trim trailing whitespace from a byte sequence. If the argument " "`set` is provided, consider only characters in `set` to be whitespace.") { JanetByteView str, set; trim_help_args(argc, argv, &str, &set); int32_t right_edge = trim_help_rightedge(str, set); return janet_stringv(str.bytes, right_edge); } /* Module entry point */ void janet_lib_string(JanetTable *env) { JanetRegExt string_cfuns[] = { JANET_CORE_REG("string/slice", cfun_string_slice), JANET_CORE_REG("keyword/slice", cfun_keyword_slice), JANET_CORE_REG("symbol/slice", cfun_symbol_slice), JANET_CORE_REG("string/repeat", cfun_string_repeat), JANET_CORE_REG("string/bytes", cfun_string_bytes), JANET_CORE_REG("string/from-bytes", cfun_string_frombytes), JANET_CORE_REG("string/ascii-lower", cfun_string_asciilower), JANET_CORE_REG("string/ascii-upper", cfun_string_asciiupper), JANET_CORE_REG("string/reverse", cfun_string_reverse), JANET_CORE_REG("string/find", cfun_string_find), JANET_CORE_REG("string/find-all", cfun_string_findall), JANET_CORE_REG("string/has-prefix?", cfun_string_hasprefix), JANET_CORE_REG("string/has-suffix?", cfun_string_hassuffix), JANET_CORE_REG("string/replace", cfun_string_replace), JANET_CORE_REG("string/replace-all", cfun_string_replaceall), JANET_CORE_REG("string/split", cfun_string_split), JANET_CORE_REG("string/check-set", cfun_string_checkset), JANET_CORE_REG("string/join", cfun_string_join), JANET_CORE_REG("string/format", cfun_string_format), JANET_CORE_REG("string/trim", cfun_string_trim), JANET_CORE_REG("string/triml", cfun_string_triml), JANET_CORE_REG("string/trimr", cfun_string_trimr), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, string_cfuns); } janet-1.41.2/src/core/strtod.c000066400000000000000000000432131514534607600161200ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ /* Use a custom double parser instead of libc's strtod for better portability * and control. * * This version has been modified for much greater flexibility in parsing, such * as choosing the radix and supporting scientific notation with any radix. * * Numbers are of the form [-+]R[rR]I.F[eE&][-+]X in pseudo-regex form, where R * is the radix, I is the integer part, F is the fractional part, and X is the * exponent. All signs, radix, decimal point, fractional part, and exponent can * be omitted. The radix is assumed to be 10 if omitted, and the E or e * separator for the exponent can only be used when the radix is 10. This is * because E is a valid digit in bases 15 or greater. For bases greater than * 10, the letters are used as digits. A through Z correspond to the digits 10 * through 35, and the lowercase letters have the same values. The radix number * is always in base 10. For example, a hexadecimal number could be written * '16rdeadbeef'. janet_scan_number also supports some c style syntax for * hexadecimal literals. The previous number could also be written * '0xdeadbeef'. */ #ifndef JANET_AMALG #include "features.h" #include #include "util.h" #endif #include #include /* Lookup table for getting values of characters when parsing numbers. Handles * digits 0-9 and a-z (and A-Z). A-Z have values of 10 to 35. */ static uint8_t digit_lookup[128] = { 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 0xff, 0xff, 0xff, 0xff, 0xff }; #define BIGNAT_NBIT 31 #define BIGNAT_BASE 0x80000000U /* Allow for large mantissa. BigNat is a natural number. */ struct BigNat { uint32_t first_digit; /* First digit so we don't need to allocate when not needed. */ int32_t n; /* n digits */ int32_t cap; /* allocated digit capacity */ uint32_t *digits; /* Each digit is base (2 ^ 31). Digits are least significant first. */ }; /* Initialize a bignat to 0 */ static void bignat_zero(struct BigNat *x) { x->first_digit = 0; x->n = 0; x->cap = 0; x->digits = NULL; } /* Allocate n more digits for mant. Return a pointer to these digits. */ static uint32_t *bignat_extra(struct BigNat *mant, int32_t n) { int32_t oldn = mant->n; int32_t newn = oldn + n; if (mant->cap < newn) { int32_t newcap = 2 * newn; uint32_t *mem = janet_realloc(mant->digits, (size_t) newcap * sizeof(uint32_t)); if (NULL == mem) { JANET_OUT_OF_MEMORY; } mant->cap = newcap; mant->digits = mem; } mant->n = newn; return mant->digits + oldn; } /* Append a digit */ static void bignat_append(struct BigNat *mant, uint32_t dig) { bignat_extra(mant, 1)[0] = dig; } /* Multiply the mantissa mant by a factor and the add a term * in one operation. factor will be between 2 and 36^4, * term will be between 0 and 36. */ static void bignat_muladd(struct BigNat *mant, uint32_t factor, uint32_t term) { int32_t i; uint64_t carry = ((uint64_t) mant->first_digit) * factor + term; mant->first_digit = carry % BIGNAT_BASE; carry /= BIGNAT_BASE; for (i = 0; i < mant->n; i++) { carry += ((uint64_t) mant->digits[i]) * factor; mant->digits[i] = carry % BIGNAT_BASE; carry /= BIGNAT_BASE; } if (carry) bignat_append(mant, (uint32_t) carry); } /* Divide the mantissa mant by a factor. Drop the remainder. */ static void bignat_div(struct BigNat *mant, uint32_t divisor) { int32_t i; uint32_t quotient, remainder; uint64_t dividend; remainder = 0, quotient = 0; for (i = mant->n - 1; i >= 0; i--) { dividend = ((uint64_t)remainder * BIGNAT_BASE) + mant->digits[i]; if (i < mant->n - 1) mant->digits[i + 1] = quotient; quotient = (uint32_t)(dividend / divisor); remainder = (uint32_t)(dividend % divisor); mant->digits[i] = remainder; } dividend = ((uint64_t)remainder * BIGNAT_BASE) + mant->first_digit; if (mant->n && mant->digits[mant->n - 1] == 0) mant->n--; mant->first_digit = (uint32_t)(dividend / divisor); } /* Shift left by a multiple of BIGNAT_NBIT */ static void bignat_lshift_n(struct BigNat *mant, int n) { if (!n) return; int32_t oldn = mant->n; bignat_extra(mant, n); memmove(mant->digits + n, mant->digits, sizeof(uint32_t) * oldn); memset(mant->digits, 0, sizeof(uint32_t) * (n - 1)); mant->digits[n - 1] = mant->first_digit; mant->first_digit = 0; } #ifdef __GNUC__ #define clz(x) __builtin_clz(x) #else static int clz(uint32_t x) { int n = 0; if (x <= 0x0000ffff) n += 16, x <<= 16; if (x <= 0x00ffffff) n += 8, x <<= 8; if (x <= 0x0fffffff) n += 4, x <<= 4; if (x <= 0x3fffffff) n += 2, x <<= 2; if (x <= 0x7fffffff) n ++; return n; } #endif /* Extract double value from mantissa */ static double bignat_extract(struct BigNat *mant, int32_t exponent2) { uint64_t top53; int32_t n = mant->n; /* Get most significant 53 bits from mant. Bit 52 (0 indexed) should * always be 1. This is essentially a large right shift on mant.*/ if (n) { /* Two or more digits */ uint64_t d1 = mant->digits[n - 1]; /* MSD (non-zero) */ uint64_t d2 = (n == 1) ? mant->first_digit : mant->digits[n - 2]; uint64_t d3 = (n > 2) ? mant->digits[n - 3] : (n == 2) ? mant->first_digit : 0; int lz = clz((uint32_t) d1); int nbits = 32 - lz; /* First get 54 bits */ top53 = (d2 << (54 - BIGNAT_NBIT)) + (d3 >> (2 * BIGNAT_NBIT - 54)); top53 >>= nbits; top53 |= (d1 << (54 - nbits)); /* Rounding based on lowest bit of 54 */ if (top53 & 1) top53++; top53 >>= 1; if (top53 > 0x1FffffFFFFffffUL) { top53 >>= 1; exponent2++; } /* Correct exponent - to correct for large right shift to mantissa. */ exponent2 += (nbits - 53) + BIGNAT_NBIT * n; } else { /* One digit */ top53 = mant->first_digit; } return ldexp((double)top53, exponent2); } /* Read in a mantissa and exponent of a certain base, and give * back the double value. Should properly handle 0s, infinities, and * denormalized numbers. (When the exponent values are too large or small) */ static double convert( int negative, struct BigNat *mant, int32_t base, int32_t exponent) { int32_t exponent2 = 0; /* Approximate exponent in base 2 of mant and exponent. This should get us a good estimate of the final size of the * number, within * 2^32 or so. */ int64_t mant_exp2_approx = mant->n * 32 + 16; int64_t exp_exp2_approx = (int64_t)(floor(log2(base) * exponent)); int64_t exp2_approx = mant_exp2_approx + exp_exp2_approx; /* Short circuit zero, huge, and small numbers. We use the exponent range of valid IEEE754 doubles (-1022, 1023) * with a healthy buffer to allow for inaccuracies in the approximation and denormailzed numbers. */ if (mant->n == 0 && mant->first_digit == 0) return negative ? -0.0 : 0.0; if (exp2_approx > 1176) return negative ? -INFINITY : INFINITY; if (exp2_approx < -1175) return negative ? -0.0 : 0.0; /* Final value is X = mant * base ^ exponent * 2 ^ exponent2 * Get exponent to zero while holding X constant. */ /* Positive exponents are simple */ for (; exponent > 3; exponent -= 4) bignat_muladd(mant, base * base * base * base, 0); for (; exponent > 1; exponent -= 2) bignat_muladd(mant, base * base, 0); for (; exponent > 0; exponent -= 1) bignat_muladd(mant, base, 0); /* Negative exponents are tricky - we don't want to loose bits * from integer division, so we need to premultiply. */ if (exponent < 0) { int32_t shamt = 5 - exponent / 4; bignat_lshift_n(mant, shamt); exponent2 -= shamt * BIGNAT_NBIT; for (; exponent < -3; exponent += 4) bignat_div(mant, base * base * base * base); for (; exponent < -1; exponent += 2) bignat_div(mant, base * base); for (; exponent < 0; exponent += 1) bignat_div(mant, base); } return negative ? -bignat_extract(mant, exponent2) : bignat_extract(mant, exponent2); } /* Scan a real (double) from a string. If the string cannot be converted into * and integer, return 0. */ int janet_scan_number_base( const uint8_t *str, int32_t len, int32_t base, double *out) { const uint8_t *end = str + len; int seenadigit = 0; int ex = 0; int seenpoint = 0; int foundexp = 0; int neg = 0; struct BigNat mant; bignat_zero(&mant); /* Prevent some kinds of overflow bugs relating to the exponent * overflowing. For example, if a string was passed 2GB worth of 0s after * the decimal point, exponent could wrap around and become positive. It's * easier to reject ridiculously large inputs than to check for overflows. * */ if (len > INT32_MAX / 40) goto error; /* Get sign */ if (str >= end) goto error; if (*str == '-') { neg = 1; str++; } else if (*str == '+') { str++; } /* Check for leading 0x or digit digit r */ if (base == 0) { if (str + 1 < end && str[0] == '0' && str[1] == 'x') { base = 16; str += 2; } else if (str + 1 < end && str[0] >= '0' && str[0] <= '9' && str[1] == 'r') { base = str[0] - '0'; str += 2; } else if (str + 2 < end && str[0] >= '0' && str[0] <= '9' && str[1] >= '0' && str[1] <= '9' && str[2] == 'r') { base = 10 * (str[0] - '0') + (str[1] - '0'); if (base < 2 || base > 36) goto error; str += 3; } } /* If still base is 0, set to default (10) */ if (base == 0) { base = 10; } int exp_base = base; /* Skip leading zeros */ while (str < end && (*str == '0' || *str == '.')) { if (seenpoint) ex--; if (*str == '.') { if (seenpoint) goto error; seenpoint = 1; } else { seenadigit = 1; } str++; } /* Parse significant digits */ while (str < end) { if (*str == '.') { if (seenpoint) goto error; seenpoint = 1; } else if (*str == '&') { foundexp = 1; break; } else if (base == 16 && (*str == 'P' || *str == 'p')) { /* IEEE hex float */ foundexp = 1; exp_base = 10; base = 2; ex *= 4; /* We need to correct the current exponent after we change the base */ break; } else if (base == 10 && (*str == 'E' || *str == 'e')) { foundexp = 1; break; } else if (*str == '_') { if (!seenadigit) goto error; } else { int digit = digit_lookup[*str & 0x7F]; if (*str > 127 || digit >= base) goto error; if (seenpoint) ex--; bignat_muladd(&mant, base, digit); seenadigit = 1; } str++; } if (!seenadigit) goto error; /* Read exponent */ if (str < end && foundexp) { int eneg = 0; int32_t ee = 0; seenadigit = 0; str++; if (str >= end) goto error; if (*str == '-') { eneg = 1; str++; } else if (*str == '+') { str++; } /* Skip leading 0s in exponent */ while (str < end && *str == '0') { str++; seenadigit = 1; } while (str < end) { int digit = digit_lookup[*str & 0x7F]; if (*str > 127 || digit >= exp_base) goto error; if (ee < (INT32_MAX / 40)) { ee = exp_base * ee + digit; } str++; seenadigit = 1; } if (eneg) ex -= ee; else ex += ee; } if (!seenadigit) goto error; *out = convert(neg, &mant, base, ex); janet_free(mant.digits); return 0; error: janet_free(mant.digits); return 1; } int janet_scan_number( const uint8_t *str, int32_t len, double *out) { return janet_scan_number_base(str, len, 0, out); } #ifdef JANET_INT_TYPES static int scan_uint64( const uint8_t *str, int32_t len, uint64_t *out, int *neg) { const uint8_t *end = str + len; int seenadigit = 0; int base = 10; *neg = 0; *out = 0; uint64_t accum = 0; /* len max is INT64_MAX in base 2 with _ between each bits */ /* '2r' + 64 bits + 63 _ + sign = 130 => 150 for some leading */ /* zeros */ if (len > 150) return 0; /* Get sign */ if (str >= end) return 0; if (*str == '-') { *neg = 1; str++; } else if (*str == '+') { str++; } /* Check for leading 0x or digit digit r */ if (str + 1 < end && str[0] == '0' && str[1] == 'x') { base = 16; str += 2; } else if (str + 1 < end && str[0] >= '0' && str[0] <= '9' && str[1] == 'r') { base = str[0] - '0'; str += 2; } else if (str + 2 < end && str[0] >= '0' && str[0] <= '9' && str[1] >= '0' && str[1] <= '9' && str[2] == 'r') { base = 10 * (str[0] - '0') + (str[1] - '0'); if (base < 2 || base > 36) return 0; str += 3; } /* Skip leading zeros */ while (str < end && *str == '0') { seenadigit = 1; str++; } /* Parse significant digits */ while (str < end) { if (*str == '_') { if (!seenadigit) return 0; } else { int digit = digit_lookup[*str & 0x7F]; if (*str > 127 || digit >= base) return 0; if (accum > (UINT64_MAX - digit) / base) return 0; accum = accum * base + digit; seenadigit = 1; } str++; } if (!seenadigit) return 0; *out = accum; return 1; } int janet_scan_int64(const uint8_t *str, int32_t len, int64_t *out) { int neg; uint64_t bi; if (scan_uint64(str, len, &bi, &neg)) { if (neg && bi <= ((UINT64_MAX / 2) + 1)) { if (bi > INT64_MAX) { *out = INT64_MIN; } else { *out = -((int64_t) bi); } return 1; } if (!neg && bi <= INT64_MAX) { *out = (int64_t) bi; return 1; } } return 0; } int janet_scan_uint64(const uint8_t *str, int32_t len, uint64_t *out) { int neg; uint64_t bi; if (scan_uint64(str, len, &bi, &neg)) { if (!neg) { *out = bi; return 1; } } return 0; } /* Similar to janet_scan_number but allows for * more numeric types with a given suffix. */ int janet_scan_numeric( const uint8_t *str, int32_t len, Janet *out) { int result; double num; int64_t i64 = 0; uint64_t u64 = 0; if (len < 2 || str[len - 2] != ':') { result = janet_scan_number_base(str, len, 0, &num); *out = janet_wrap_number(num); return result; } switch (str[len - 1]) { default: return 1; case 'n': result = janet_scan_number_base(str, len - 2, 0, &num); *out = janet_wrap_number(num); return result; /* Condition is inverted janet_scan_int64 and janet_scan_uint64 */ case 's': result = !janet_scan_int64(str, len - 2, &i64); *out = janet_wrap_s64(i64); return result; case 'u': result = !janet_scan_uint64(str, len - 2, &u64); *out = janet_wrap_u64(u64); return result; } } #endif void janet_buffer_dtostr(JanetBuffer *buffer, double x) { #define BUFSIZE 32 janet_buffer_extra(buffer, BUFSIZE); int count = snprintf((char *) buffer->data + buffer->count, BUFSIZE, "%.17g", x); #undef BUFSIZE /* fix locale issues with commas */ for (int i = 0; i < count; i++) { char c = buffer->data[buffer->count + i]; if (c == ',') { buffer->data[buffer->count + i] = '.'; } } buffer->count += count; } janet-1.41.2/src/core/struct.c000066400000000000000000000302701514534607600161240ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "gc.h" #include "util.h" #include #endif /* Begin creation of a struct */ JanetKV *janet_struct_begin(int32_t count) { /* Calculate capacity as power of 2 after 2 * count. */ int32_t capacity = janet_tablen(2 * count); if (capacity < 0) capacity = janet_tablen(count + 1); size_t size = sizeof(JanetStructHead) + (size_t) capacity * sizeof(JanetKV); JanetStructHead *head = janet_gcalloc(JANET_MEMORY_STRUCT, size); head->length = count; head->capacity = capacity; head->hash = 0; head->proto = NULL; JanetKV *st = (JanetKV *)(head->data); janet_memempty(st, capacity); return st; } /* Find an item in a struct without looking for prototypes. Should be similar to janet_dict_find, but * specialized to structs (slightly more compact). */ const JanetKV *janet_struct_find(const JanetKV *st, Janet key) { int32_t cap = janet_struct_capacity(st); int32_t index = janet_maphash(cap, janet_hash(key)); int32_t i; for (i = index; i < cap; i++) if (janet_checktype(st[i].key, JANET_NIL) || janet_equals(st[i].key, key)) return st + i; for (i = 0; i < index; i++) if (janet_checktype(st[i].key, JANET_NIL) || janet_equals(st[i].key, key)) return st + i; return NULL; } /* Put a kv pair into a struct that has not yet been fully constructed. * Nil keys and values are ignored, extra keys are ignore, and duplicate keys are * ignored. * * Runs will be in sorted order, as the collisions resolver essentially * preforms an in-place insertion sort. This ensures the internal structure of the * hash map is independent of insertion order. */ void janet_struct_put_ext(JanetKV *st, Janet key, Janet value, int replace) { int32_t cap = janet_struct_capacity(st); int32_t hash = janet_hash(key); int32_t index = janet_maphash(cap, hash); int32_t i, j, dist; int32_t bounds[4] = {index, cap, 0, index}; if (janet_checktype(key, JANET_NIL) || janet_checktype(value, JANET_NIL)) return; if (janet_checktype(key, JANET_NUMBER) && isnan(janet_unwrap_number(key))) return; /* Avoid extra items */ if (janet_struct_hash(st) == janet_struct_length(st)) return; for (dist = 0, j = 0; j < 4; j += 2) for (i = bounds[j]; i < bounds[j + 1]; i++, dist++) { int status; int32_t otherhash; int32_t otherindex, otherdist; JanetKV *kv = st + i; /* We found an empty slot, so just add key and value */ if (janet_checktype(kv->key, JANET_NIL)) { kv->key = key; kv->value = value; /* Update the temporary count */ janet_struct_hash(st)++; return; } /* Robinhood hashing - check if colliding kv pair * is closer to their source than current. We use robinhood * hashing to ensure that equivalent structs that are constructed * with different order have the same internal layout, and therefor * will compare properly - i.e., {1 2 3 4} should equal {3 4 1 2}. * Collisions are resolved via an insertion sort insertion. */ otherhash = janet_hash(kv->key); otherindex = janet_maphash(cap, otherhash); otherdist = (i + cap - otherindex) & (cap - 1); if (dist < otherdist) status = -1; else if (otherdist < dist) status = 1; else if (hash < otherhash) status = -1; else if (otherhash < hash) status = 1; else status = janet_compare(key, kv->key); /* If other is closer to their ideal slot */ if (status == 1) { /* Swap current kv pair with pair in slot */ JanetKV temp = *kv; kv->key = key; kv->value = value; key = temp.key; value = temp.value; /* Save dist and hash of new kv pair */ dist = otherdist; hash = otherhash; } else if (status == 0) { if (replace) { /* A key was added to the struct more than once - replace old value */ kv->value = value; } return; } } } void janet_struct_put(JanetKV *st, Janet key, Janet value) { janet_struct_put_ext(st, key, value, 1); } /* Finish building a struct */ const JanetKV *janet_struct_end(JanetKV *st) { if (janet_struct_hash(st) != janet_struct_length(st)) { /* Error building struct, probably duplicate values. We need to rebuild * the struct using only the values that went in. The second creation should always * succeed. */ JanetKV *newst = janet_struct_begin(janet_struct_hash(st)); for (int32_t i = 0; i < janet_struct_capacity(st); i++) { JanetKV *kv = st + i; if (!janet_checktype(kv->key, JANET_NIL)) { janet_struct_put(newst, kv->key, kv->value); } } janet_struct_proto(newst) = janet_struct_proto(st); st = newst; } janet_struct_hash(st) = janet_kv_calchash(st, janet_struct_capacity(st)); if (janet_struct_proto(st)) { janet_struct_hash(st) += 2654435761u * janet_struct_hash(janet_struct_proto(st)); } return (const JanetKV *)st; } /* Get an item from a struct without looking into prototypes. */ Janet janet_struct_rawget(const JanetKV *st, Janet key) { const JanetKV *kv = janet_struct_find(st, key); return kv ? kv->value : janet_wrap_nil(); } /* Get an item from a struct */ Janet janet_struct_get(const JanetKV *st, Janet key) { for (int i = JANET_MAX_PROTO_DEPTH; st && i; --i, st = janet_struct_proto(st)) { const JanetKV *kv = janet_struct_find(st, key); if (NULL != kv && !janet_checktype(kv->key, JANET_NIL)) { return kv->value; } } return janet_wrap_nil(); } /* Get an item from a struct, and record which prototype the item came from. */ Janet janet_struct_get_ex(const JanetKV *st, Janet key, JanetStruct *which) { for (int i = JANET_MAX_PROTO_DEPTH; st && i; --i, st = janet_struct_proto(st)) { const JanetKV *kv = janet_struct_find(st, key); if (NULL != kv && !janet_checktype(kv->key, JANET_NIL)) { *which = st; return kv->value; } } return janet_wrap_nil(); } /* Convert struct to table */ JanetTable *janet_struct_to_table(const JanetKV *st) { JanetTable *table = janet_table(janet_struct_capacity(st)); int32_t i; for (i = 0; i < janet_struct_capacity(st); i++) { const JanetKV *kv = st + i; if (!janet_checktype(kv->key, JANET_NIL)) { janet_table_put(table, kv->key, kv->value); } } return table; } /* C Functions */ JANET_CORE_FN(cfun_struct_with_proto, "(struct/with-proto proto & kvs)", "Create a structure, as with the usual struct constructor but set the " "struct prototype as well.") { janet_arity(argc, 1, -1); JanetStruct proto = janet_optstruct(argv, argc, 0, NULL); if (!(argc & 1)) janet_panic("expected odd number of arguments"); JanetKV *st = janet_struct_begin(argc / 2); for (int32_t i = 1; i < argc; i += 2) { janet_struct_put(st, argv[i], argv[i + 1]); } janet_struct_proto(st) = proto; return janet_wrap_struct(janet_struct_end(st)); } JANET_CORE_FN(cfun_struct_getproto, "(struct/getproto st)", "Return the prototype of a struct, or nil if it doesn't have one.") { janet_fixarity(argc, 1); JanetStruct st = janet_getstruct(argv, 0); return janet_struct_proto(st) ? janet_wrap_struct(janet_struct_proto(st)) : janet_wrap_nil(); } JANET_CORE_FN(cfun_struct_flatten, "(struct/proto-flatten st)", "Convert a struct with prototypes to a struct with no prototypes by merging " "all key value pairs from recursive prototypes into one new struct.") { janet_fixarity(argc, 1); JanetStruct st = janet_getstruct(argv, 0); /* get an upper bounds on the number of items in the final struct */ int64_t pair_count = 0; JanetStruct cursor = st; while (cursor) { pair_count += janet_struct_length(cursor); cursor = janet_struct_proto(cursor); } if (pair_count > INT32_MAX) { janet_panic("struct too large"); } JanetKV *accum = janet_struct_begin((int32_t) pair_count); cursor = st; while (cursor) { for (int32_t i = 0; i < janet_struct_capacity(cursor); i++) { const JanetKV *kv = cursor + i; if (!janet_checktype(kv->key, JANET_NIL)) { janet_struct_put_ext(accum, kv->key, kv->value, 0); } } cursor = janet_struct_proto(cursor); } return janet_wrap_struct(janet_struct_end(accum)); } JANET_CORE_FN(cfun_struct_to_table, "(struct/to-table st &opt recursive)", "Convert a struct to a table. If recursive is true, also convert the " "table's prototypes into the new struct's prototypes as well.") { janet_arity(argc, 1, 2); JanetStruct st = janet_getstruct(argv, 0); int recursive = argc > 1 && janet_truthy(argv[1]); JanetTable *tab = NULL; JanetStruct cursor = st; JanetTable *tab_cursor = tab; do { if (tab) { tab_cursor->proto = janet_table(janet_struct_length(cursor)); tab_cursor = tab_cursor->proto; } else { tab = janet_table(janet_struct_length(cursor)); tab_cursor = tab; } /* TODO - implement as memcpy since struct memory should be compatible * with table memory */ for (int32_t i = 0; i < janet_struct_capacity(cursor); i++) { const JanetKV *kv = cursor + i; if (!janet_checktype(kv->key, JANET_NIL)) { janet_table_put(tab_cursor, kv->key, kv->value); } } cursor = janet_struct_proto(cursor); } while (recursive && cursor); return janet_wrap_table(tab); } JANET_CORE_FN(cfun_struct_rawget, "(struct/rawget st key)", "Gets a value from a struct `st` without looking at the prototype struct. " "If `st` does not contain the key directly, the function will return " "nil without checking the prototype. Returns the value in the struct.") { janet_fixarity(argc, 2); JanetStruct st = janet_getstruct(argv, 0); return janet_struct_rawget(st, argv[1]); } /* Load the struct module */ void janet_lib_struct(JanetTable *env) { JanetRegExt struct_cfuns[] = { JANET_CORE_REG("struct/with-proto", cfun_struct_with_proto), JANET_CORE_REG("struct/getproto", cfun_struct_getproto), JANET_CORE_REG("struct/proto-flatten", cfun_struct_flatten), JANET_CORE_REG("struct/to-table", cfun_struct_to_table), JANET_CORE_REG("struct/rawget", cfun_struct_rawget), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, struct_cfuns); } janet-1.41.2/src/core/symcache.c000066400000000000000000000206501514534607600163750ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ /* The symbol cache is an open hashtable with all active symbols in the program * stored in it. As the primary use of symbols is table lookups and equality * checks, all symbols are interned so that there is a single copy of it in the * whole program. Equality is then just a pointer check. */ #ifndef JANET_AMALG #include "features.h" #include #include "state.h" #include "gc.h" #include "util.h" #include "symcache.h" #endif #include /* Initialize the cache (allocate cache memory) */ void janet_symcache_init() { janet_vm.cache_capacity = 1024; janet_vm.cache = janet_calloc(1, (size_t) janet_vm.cache_capacity * sizeof(const uint8_t *)); if (NULL == janet_vm.cache) { JANET_OUT_OF_MEMORY; } memset(&janet_vm.gensym_counter, '0', sizeof(janet_vm.gensym_counter)); janet_vm.gensym_counter[0] = '_'; janet_vm.cache_count = 0; janet_vm.cache_deleted = 0; } /* Deinitialize the cache (free the cache memory) */ void janet_symcache_deinit() { janet_free((void *)janet_vm.cache); janet_vm.cache = NULL; janet_vm.cache_capacity = 0; janet_vm.cache_count = 0; janet_vm.cache_deleted = 0; } /* Mark an entry in the table as deleted. */ static const uint8_t JANET_SYMCACHE_DELETED[1] = {0}; /* Find an item in the cache and return its location. * If the item is not found, return the location * where one would put it. */ static const uint8_t **janet_symcache_findmem( const uint8_t *str, int32_t len, int32_t hash, int *success) { uint32_t bounds[4]; uint32_t i, j, index; const uint8_t **firstEmpty = NULL; /* We will search two ranges - index to the end, * and 0 to the index. */ index = (uint32_t)hash & (janet_vm.cache_capacity - 1); bounds[0] = index; bounds[1] = janet_vm.cache_capacity; bounds[2] = 0; bounds[3] = index; for (j = 0; j < 4; j += 2) for (i = bounds[j]; i < bounds[j + 1]; ++i) { const uint8_t *test = janet_vm.cache[i]; /* Check empty spots */ if (NULL == test) { if (NULL == firstEmpty) firstEmpty = janet_vm.cache + i; goto notfound; } /* Check for marked deleted */ if (JANET_SYMCACHE_DELETED == test) { if (firstEmpty == NULL) firstEmpty = janet_vm.cache + i; continue; } if (janet_string_equalconst(test, str, len, hash)) { /* Replace first deleted */ *success = 1; if (firstEmpty != NULL) { *firstEmpty = test; janet_vm.cache[i] = JANET_SYMCACHE_DELETED; return firstEmpty; } return janet_vm.cache + i; } } notfound: *success = 0; janet_assert(firstEmpty != NULL, "symcache failed to get memory"); return firstEmpty; } #define janet_symcache_find(str, success) \ janet_symcache_findmem((str), janet_string_length(str), janet_string_hash(str), (success)) /* Resize the cache. */ static void janet_cache_resize(uint32_t newCapacity) { uint32_t i, oldCapacity; const uint8_t **oldCache = janet_vm.cache; const uint8_t **newCache = janet_calloc(1, (size_t) newCapacity * sizeof(const uint8_t *)); if (newCache == NULL) { JANET_OUT_OF_MEMORY; } oldCapacity = janet_vm.cache_capacity; janet_vm.cache = newCache; janet_vm.cache_capacity = newCapacity; janet_vm.cache_deleted = 0; /* Add all of the old cache entries back */ for (i = 0; i < oldCapacity; ++i) { int status; const uint8_t **bucket; const uint8_t *x = oldCache[i]; if (x != NULL && x != JANET_SYMCACHE_DELETED) { bucket = janet_symcache_find(x, &status); if (status || bucket == NULL) { /* there was a problem with the algorithm. */ break; } *bucket = x; } } /* Free the old cache */ janet_free((void *)oldCache); } /* Add an item to the cache */ static void janet_symcache_put(const uint8_t *x, const uint8_t **bucket) { if ((janet_vm.cache_count + janet_vm.cache_deleted) * 2 > janet_vm.cache_capacity) { int status; janet_cache_resize(janet_tablen((2 * janet_vm.cache_count + 1))); bucket = janet_symcache_find(x, &status); } /* Add x to the cache */ janet_vm.cache_count++; *bucket = x; } /* Remove a symbol from the symcache */ void janet_symbol_deinit(const uint8_t *sym) { int status = 0; const uint8_t **bucket = janet_symcache_find(sym, &status); if (status) { janet_vm.cache_count--; janet_vm.cache_deleted++; *bucket = JANET_SYMCACHE_DELETED; } } /* Create a symbol from a byte string */ const uint8_t *janet_symbol(const uint8_t *str, int32_t len) { int32_t hash = janet_string_calchash(str, len); uint8_t *newstr; int success = 0; const uint8_t **bucket = janet_symcache_findmem(str, len, hash, &success); if (success) return *bucket; JanetStringHead *head = janet_gcalloc(JANET_MEMORY_SYMBOL, sizeof(JanetStringHead) + (size_t) len + 1); head->hash = hash; head->length = len; newstr = (uint8_t *)(head->data); safe_memcpy(newstr, str, len); newstr[len] = 0; janet_symcache_put((const uint8_t *)newstr, bucket); return newstr; } /* Get a symbol from a cstring */ const uint8_t *janet_csymbol(const char *cstr) { return janet_symbol((const uint8_t *)cstr, (int32_t) strlen(cstr)); } /* Increment the gensym buffer */ static void inc_gensym(void) { for (int i = sizeof(janet_vm.gensym_counter) - 2; i; i--) { if (janet_vm.gensym_counter[i] == '9') { janet_vm.gensym_counter[i] = 'a'; break; } else if (janet_vm.gensym_counter[i] == 'z') { janet_vm.gensym_counter[i] = 'A'; break; } else if (janet_vm.gensym_counter[i] == 'Z') { janet_vm.gensym_counter[i] = '0'; } else { janet_vm.gensym_counter[i]++; break; } } } /* Generate a unique symbol. This is used in the library function gensym. The * symbol will be of the format _XXXXXX, where X is a base64 digit, and * prefix is the argument passed. No prefix for speed. */ const uint8_t *janet_symbol_gen(void) { const uint8_t **bucket = NULL; uint8_t *sym; int32_t hash = 0; int status; /* Leave spaces for 6 base 64 digits and two dashes. That means 64^6 possible suffixes, which * is enough for resolving collisions. */ do { hash = janet_string_calchash( janet_vm.gensym_counter, sizeof(janet_vm.gensym_counter) - 1); bucket = janet_symcache_findmem( janet_vm.gensym_counter, sizeof(janet_vm.gensym_counter) - 1, hash, &status); } while (status && (inc_gensym(), 1)); JanetStringHead *head = janet_gcalloc(JANET_MEMORY_SYMBOL, sizeof(JanetStringHead) + sizeof(janet_vm.gensym_counter)); head->length = sizeof(janet_vm.gensym_counter) - 1; head->hash = hash; sym = (uint8_t *)(head->data); memcpy(sym, janet_vm.gensym_counter, sizeof(janet_vm.gensym_counter)); sym[head->length] = 0; janet_symcache_put((const uint8_t *)sym, bucket); return (const uint8_t *)sym; } janet-1.41.2/src/core/symcache.h000066400000000000000000000025741514534607600164070ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_SYMCACHE_H_defined #define JANET_SYMCACHE_H_defined #ifndef JANET_AMALG #include "features.h" #include #endif /* Initialize the cache (allocate cache memory) */ void janet_symcache_init(void); void janet_symcache_deinit(void); void janet_symbol_deinit(const uint8_t *sym); #endif janet-1.41.2/src/core/table.c000066400000000000000000000370031514534607600156700ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "gc.h" #include "util.h" #include #endif #define JANET_TABLE_FLAG_STACK 0x10000 static void *janet_memalloc_empty_local(int32_t count) { int32_t i; void *mem = janet_smalloc((size_t) count * sizeof(JanetKV)); JanetKV *mmem = (JanetKV *)mem; for (i = 0; i < count; i++) { JanetKV *kv = mmem + i; kv->key = janet_wrap_nil(); kv->value = janet_wrap_nil(); } return mem; } static JanetTable *janet_table_init_impl(JanetTable *table, int32_t capacity, int stackalloc) { JanetKV *data; capacity = janet_tablen(capacity); if (stackalloc) table->gc.flags = JANET_TABLE_FLAG_STACK; if (capacity) { if (stackalloc) { data = janet_memalloc_empty_local(capacity); } else { data = (JanetKV *) janet_memalloc_empty(capacity); if (NULL == data) { JANET_OUT_OF_MEMORY; } } table->data = data; table->capacity = capacity; } else { table->data = NULL; table->capacity = 0; } table->count = 0; table->deleted = 0; table->proto = NULL; return table; } /* Initialize a table (for use with scratch memory) */ JanetTable *janet_table_init(JanetTable *table, int32_t capacity) { return janet_table_init_impl(table, capacity, 1); } /* Initialize a table without using scratch memory */ JanetTable *janet_table_init_raw(JanetTable *table, int32_t capacity) { return janet_table_init_impl(table, capacity, 0); } /* Deinitialize a table */ void janet_table_deinit(JanetTable *table) { if (table->gc.flags & JANET_TABLE_FLAG_STACK) { janet_sfree(table->data); } else { janet_free(table->data); } } /* Create a new table */ JanetTable *janet_table(int32_t capacity) { JanetTable *table = janet_gcalloc(JANET_MEMORY_TABLE, sizeof(JanetTable)); return janet_table_init_impl(table, capacity, 0); } JanetTable *janet_table_weakk(int32_t capacity) { JanetTable *table = janet_gcalloc(JANET_MEMORY_TABLE_WEAKK, sizeof(JanetTable)); return janet_table_init_impl(table, capacity, 0); } JanetTable *janet_table_weakv(int32_t capacity) { JanetTable *table = janet_gcalloc(JANET_MEMORY_TABLE_WEAKV, sizeof(JanetTable)); return janet_table_init_impl(table, capacity, 0); } JanetTable *janet_table_weakkv(int32_t capacity) { JanetTable *table = janet_gcalloc(JANET_MEMORY_TABLE_WEAKKV, sizeof(JanetTable)); return janet_table_init_impl(table, capacity, 0); } /* Find the bucket that contains the given key. Will also return * bucket where key should go if not in the table. */ JanetKV *janet_table_find(JanetTable *t, Janet key) { return (JanetKV *) janet_dict_find(t->data, t->capacity, key); } /* Resize the dictionary table. */ static void janet_table_rehash(JanetTable *t, int32_t size) { JanetKV *olddata = t->data; JanetKV *newdata; int islocal = t->gc.flags & JANET_TABLE_FLAG_STACK; if (islocal) { newdata = (JanetKV *) janet_memalloc_empty_local(size); } else { newdata = (JanetKV *) janet_memalloc_empty(size); if (NULL == newdata) { JANET_OUT_OF_MEMORY; } } int32_t oldcapacity = t->capacity; t->data = newdata; t->capacity = size; t->deleted = 0; for (int32_t i = 0; i < oldcapacity; i++) { JanetKV *kv = olddata + i; if (!janet_checktype(kv->key, JANET_NIL)) { JanetKV *newkv = janet_table_find(t, kv->key); *newkv = *kv; } } if (islocal) { janet_sfree(olddata); } else { janet_free(olddata); } } /* Get a value out of the table */ Janet janet_table_get(JanetTable *t, Janet key) { for (int i = JANET_MAX_PROTO_DEPTH; t && i; t = t->proto, --i) { JanetKV *bucket = janet_table_find(t, key); if (NULL != bucket && !janet_checktype(bucket->key, JANET_NIL)) return bucket->value; } return janet_wrap_nil(); } /* Used internally for compiler stuff */ Janet janet_table_get_keyword(JanetTable *t, const char *keyword) { int32_t keyword_len = (int32_t) strlen(keyword); for (int i = JANET_MAX_PROTO_DEPTH; t && i; t = t->proto, --i) { JanetKV *bucket = (JanetKV *) janet_dict_find_keyword(t->data, t->capacity, (const uint8_t *) keyword, keyword_len); if (NULL != bucket && !janet_checktype(bucket->key, JANET_NIL)) return bucket->value; } return janet_wrap_nil(); } /* Get a value out of the table, and record which prototype it was from. */ Janet janet_table_get_ex(JanetTable *t, Janet key, JanetTable **which) { for (int i = JANET_MAX_PROTO_DEPTH; t && i; t = t->proto, --i) { JanetKV *bucket = janet_table_find(t, key); if (NULL != bucket && !janet_checktype(bucket->key, JANET_NIL)) { *which = t; return bucket->value; } } return janet_wrap_nil(); } /* Get a value out of the table. Don't check prototype tables. */ Janet janet_table_rawget(JanetTable *t, Janet key) { JanetKV *bucket = janet_table_find(t, key); if (NULL != bucket && !janet_checktype(bucket->key, JANET_NIL)) return bucket->value; else return janet_wrap_nil(); } /* Remove an entry from the dictionary. Return the value that * was removed. */ Janet janet_table_remove(JanetTable *t, Janet key) { JanetKV *bucket = janet_table_find(t, key); if (NULL != bucket && !janet_checktype(bucket->key, JANET_NIL)) { Janet ret = bucket->value; t->count--; t->deleted++; bucket->key = janet_wrap_nil(); bucket->value = janet_wrap_false(); return ret; } else { return janet_wrap_nil(); } } /* Put a value into the object */ void janet_table_put(JanetTable *t, Janet key, Janet value) { if (janet_checktype(key, JANET_NIL)) return; if (janet_checktype(key, JANET_NUMBER) && isnan(janet_unwrap_number(key))) return; if (janet_checktype(value, JANET_NIL)) { janet_table_remove(t, key); } else { JanetKV *bucket = janet_table_find(t, key); if (NULL != bucket && !janet_checktype(bucket->key, JANET_NIL)) { bucket->value = value; } else { if (NULL == bucket || 2 * (t->count + t->deleted + 1) > t->capacity) { janet_table_rehash(t, janet_tablen(2 * t->count + 2)); } bucket = janet_table_find(t, key); if (janet_checktype(bucket->value, JANET_BOOLEAN)) --t->deleted; bucket->key = key; bucket->value = value; ++t->count; } } } /* Used internally so don't check arguments * Put into a table, but if the key already exists do nothing. */ static void janet_table_put_no_overwrite(JanetTable *t, Janet key, Janet value) { JanetKV *bucket = janet_table_find(t, key); if (NULL != bucket && !janet_checktype(bucket->key, JANET_NIL)) return; if (NULL == bucket || 2 * (t->count + t->deleted + 1) > t->capacity) { janet_table_rehash(t, janet_tablen(2 * t->count + 2)); } bucket = janet_table_find(t, key); if (janet_checktype(bucket->value, JANET_BOOLEAN)) --t->deleted; bucket->key = key; bucket->value = value; ++t->count; } /* Clear a table */ void janet_table_clear(JanetTable *t) { int32_t capacity = t->capacity; JanetKV *data = t->data; janet_memempty(data, capacity); t->count = 0; t->deleted = 0; } /* Clone a table. */ JanetTable *janet_table_clone(JanetTable *table) { JanetTable *newTable = janet_gcalloc(JANET_MEMORY_TABLE, sizeof(JanetTable)); newTable->count = table->count; newTable->capacity = table->capacity; newTable->deleted = table->deleted; newTable->proto = table->proto; newTable->data = janet_malloc(newTable->capacity * sizeof(JanetKV)); if (NULL == newTable->data) { JANET_OUT_OF_MEMORY; } memcpy(newTable->data, table->data, (size_t) table->capacity * sizeof(JanetKV)); return newTable; } /* Merge a table or struct into a table */ static void janet_table_mergekv(JanetTable *table, const JanetKV *kvs, int32_t cap) { int32_t i; for (i = 0; i < cap; i++) { const JanetKV *kv = kvs + i; if (!janet_checktype(kv->key, JANET_NIL)) { janet_table_put(table, kv->key, kv->value); } } } /* Merge a table into another table */ void janet_table_merge_table(JanetTable *table, JanetTable *other) { janet_table_mergekv(table, other->data, other->capacity); } /* Merge a struct into a table */ void janet_table_merge_struct(JanetTable *table, const JanetKV *other) { janet_table_mergekv(table, other, janet_struct_capacity(other)); } /* Convert table to struct */ const JanetKV *janet_table_to_struct(JanetTable *t) { JanetKV *st = janet_struct_begin(t->count); JanetKV *kv = t->data; JanetKV *end = t->data + t->capacity; while (kv < end) { if (!janet_checktype(kv->key, JANET_NIL)) janet_struct_put(st, kv->key, kv->value); kv++; } return janet_struct_end(st); } JanetTable *janet_table_proto_flatten(JanetTable *t) { JanetTable *newTable = janet_table(0); while (t) { JanetKV *kv = t->data; JanetKV *end = t->data + t->capacity; while (kv < end) { if (!janet_checktype(kv->key, JANET_NIL)) janet_table_put_no_overwrite(newTable, kv->key, kv->value); kv++; } t = t->proto; } return newTable; } /* C Functions */ JANET_CORE_FN(cfun_table_new, "(table/new capacity)", "Creates a new empty table with pre-allocated memory " "for `capacity` entries. This means that if one knows the number of " "entries going into a table on creation, extra memory allocation " "can be avoided. " "Returns the new table.") { janet_fixarity(argc, 1); int32_t cap = janet_getnat(argv, 0); return janet_wrap_table(janet_table(cap)); } JANET_CORE_FN(cfun_table_weak, "(table/weak capacity)", "Creates a new empty table with weak references to keys and values. Similar to `table/new`. " "Returns the new table.") { janet_fixarity(argc, 1); int32_t cap = janet_getnat(argv, 0); return janet_wrap_table(janet_table_weakkv(cap)); } JANET_CORE_FN(cfun_table_weak_keys, "(table/weak-keys capacity)", "Creates a new empty table with weak references to keys and normal references to values. Similar to `table/new`. " "Returns the new table.") { janet_fixarity(argc, 1); int32_t cap = janet_getnat(argv, 0); return janet_wrap_table(janet_table_weakk(cap)); } JANET_CORE_FN(cfun_table_weak_values, "(table/weak-values capacity)", "Creates a new empty table with normal references to keys and weak references to values. Similar to `table/new`. " "Returns the new table.") { janet_fixarity(argc, 1); int32_t cap = janet_getnat(argv, 0); return janet_wrap_table(janet_table_weakv(cap)); } JANET_CORE_FN(cfun_table_getproto, "(table/getproto tab)", "Get the prototype table of a table. Returns nil if the table " "has no prototype, otherwise returns the prototype.") { janet_fixarity(argc, 1); JanetTable *t = janet_gettable(argv, 0); return t->proto ? janet_wrap_table(t->proto) : janet_wrap_nil(); } JANET_CORE_FN(cfun_table_setproto, "(table/setproto tab proto)", "Set the prototype of a table. Returns the original table `tab`.") { janet_fixarity(argc, 2); JanetTable *table = janet_gettable(argv, 0); JanetTable *proto = NULL; if (!janet_checktype(argv[1], JANET_NIL)) { proto = janet_gettable(argv, 1); } table->proto = proto; return argv[0]; } JANET_CORE_FN(cfun_table_tostruct, "(table/to-struct tab &opt proto)", "Convert a table to a struct. Returns a new struct.") { janet_arity(argc, 1, 2); JanetTable *t = janet_gettable(argv, 0); JanetStruct proto = janet_optstruct(argv, argc, 1, NULL); JanetStruct st = janet_table_to_struct(t); janet_struct_proto(st) = proto; return janet_wrap_struct(st); } JANET_CORE_FN(cfun_table_rawget, "(table/rawget tab key)", "Gets a value from a table `tab` without looking at the prototype table. " "If `tab` does not contain the key directly, the function will return " "nil without checking the prototype. Returns the value in the table.") { janet_fixarity(argc, 2); JanetTable *table = janet_gettable(argv, 0); return janet_table_rawget(table, argv[1]); } JANET_CORE_FN(cfun_table_clone, "(table/clone tab)", "Create a copy of a table. Updates to the new table will not change the old table, " "and vice versa.") { janet_fixarity(argc, 1); JanetTable *table = janet_gettable(argv, 0); return janet_wrap_table(janet_table_clone(table)); } JANET_CORE_FN(cfun_table_clear, "(table/clear tab)", "Remove all key-value pairs in a table and return the modified table `tab`.") { janet_fixarity(argc, 1); JanetTable *table = janet_gettable(argv, 0); janet_table_clear(table); return janet_wrap_table(table); } JANET_CORE_FN(cfun_table_proto_flatten, "(table/proto-flatten tab)", "Create a new table that is the result of merging all prototypes into a new table.") { janet_fixarity(argc, 1); JanetTable *table = janet_gettable(argv, 0); return janet_wrap_table(janet_table_proto_flatten(table)); } /* Load the table module */ void janet_lib_table(JanetTable *env) { JanetRegExt table_cfuns[] = { JANET_CORE_REG("table/new", cfun_table_new), JANET_CORE_REG("table/weak", cfun_table_weak), JANET_CORE_REG("table/weak-keys", cfun_table_weak_keys), JANET_CORE_REG("table/weak-values", cfun_table_weak_values), JANET_CORE_REG("table/to-struct", cfun_table_tostruct), JANET_CORE_REG("table/getproto", cfun_table_getproto), JANET_CORE_REG("table/setproto", cfun_table_setproto), JANET_CORE_REG("table/rawget", cfun_table_rawget), JANET_CORE_REG("table/clone", cfun_table_clone), JANET_CORE_REG("table/clear", cfun_table_clear), JANET_CORE_REG("table/proto-flatten", cfun_table_proto_flatten), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, table_cfuns); } janet-1.41.2/src/core/tuple.c000066400000000000000000000143621514534607600157350ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "symcache.h" #include "gc.h" #include "util.h" #endif /* Create a new empty tuple of the given size. This will return memory * which should be filled with Janets. The memory will not be collected until * janet_tuple_end is called. */ Janet *janet_tuple_begin(int32_t length) { size_t size = sizeof(JanetTupleHead) + ((size_t) length * sizeof(Janet)); JanetTupleHead *head = janet_gcalloc(JANET_MEMORY_TUPLE, size); head->sm_line = -1; head->sm_column = -1; head->length = length; return (Janet *)(head->data); } /* Finish building a tuple */ const Janet *janet_tuple_end(Janet *tuple) { janet_tuple_hash(tuple) = janet_array_calchash(tuple, janet_tuple_length(tuple)); return (const Janet *)tuple; } /* Build a tuple with n values */ const Janet *janet_tuple_n(const Janet *values, int32_t n) { Janet *t = janet_tuple_begin(n); safe_memcpy(t, values, sizeof(Janet) * n); return janet_tuple_end(t); } /* C Functions */ JANET_CORE_FN(cfun_tuple_brackets, "(tuple/brackets & xs)", "Creates a new bracketed tuple containing the elements xs.") { const Janet *tup = janet_tuple_n(argv, argc); janet_tuple_flag(tup) |= JANET_TUPLE_FLAG_BRACKETCTOR; return janet_wrap_tuple(tup); } JANET_CORE_FN(cfun_tuple_slice, "(tuple/slice arrtup [,start=0 [,end=(length arrtup)]])", "Take a sub-sequence of an array or tuple from index `start` " "inclusive to index `end` exclusive. If `start` or `end` are not provided, " "they default to 0 and the length of `arrtup`, respectively. " "`start` and `end` can also be negative to indicate indexing " "from the end of the input. Note that if `start` is negative it is " "exclusive, and if `end` is negative it is inclusive, to allow a full " "negative slice range. Returns the new tuple.") { JanetView view = janet_getindexed(argv, 0); JanetRange range = janet_getslice(argc, argv); return janet_wrap_tuple(janet_tuple_n(view.items + range.start, range.end - range.start)); } JANET_CORE_FN(cfun_tuple_type, "(tuple/type tup)", "Checks how the tuple was constructed. Will return the keyword " ":brackets if the tuple was parsed with brackets, and :parens " "otherwise. The two types of tuples will behave the same most of " "the time, but will print differently and be treated differently by " "the compiler.") { janet_fixarity(argc, 1); const Janet *tup = janet_gettuple(argv, 0); if (janet_tuple_flag(tup) & JANET_TUPLE_FLAG_BRACKETCTOR) { return janet_ckeywordv("brackets"); } else { return janet_ckeywordv("parens"); } } JANET_CORE_FN(cfun_tuple_sourcemap, "(tuple/sourcemap tup)", "Returns the sourcemap metadata attached to a tuple, " "which is another tuple (line, column).") { janet_fixarity(argc, 1); const Janet *tup = janet_gettuple(argv, 0); Janet contents[2]; contents[0] = janet_wrap_integer(janet_tuple_head(tup)->sm_line); contents[1] = janet_wrap_integer(janet_tuple_head(tup)->sm_column); return janet_wrap_tuple(janet_tuple_n(contents, 2)); } JANET_CORE_FN(cfun_tuple_setmap, "(tuple/setmap tup line column)", "Set the sourcemap metadata on a tuple. line and column indicate " "should be integers.") { janet_fixarity(argc, 3); const Janet *tup = janet_gettuple(argv, 0); janet_tuple_head(tup)->sm_line = janet_getinteger(argv, 1); janet_tuple_head(tup)->sm_column = janet_getinteger(argv, 2); return argv[0]; } JANET_CORE_FN(cfun_tuple_join, "(tuple/join & parts)", "Create a tuple by joining together other tuples and arrays.") { janet_arity(argc, 0, -1); int32_t total_len = 0; for (int32_t i = 0; i < argc; i++) { int32_t len = 0; const Janet *vals = NULL; if (!janet_indexed_view(argv[i], &vals, &len)) { janet_panicf("expected indexed type for argument %d, got %v", i, argv[i]); } if (INT32_MAX - total_len < len) { janet_panic("tuple too large"); } total_len += len; } Janet *tup = janet_tuple_begin(total_len); Janet *tup_cursor = tup; for (int32_t i = 0; i < argc; i++) { int32_t len = 0; const Janet *vals = NULL; janet_indexed_view(argv[i], &vals, &len); memcpy(tup_cursor, vals, len * sizeof(Janet)); tup_cursor += len; } return janet_wrap_tuple(janet_tuple_end(tup)); } /* Load the tuple module */ void janet_lib_tuple(JanetTable *env) { JanetRegExt tuple_cfuns[] = { JANET_CORE_REG("tuple/brackets", cfun_tuple_brackets), JANET_CORE_REG("tuple/slice", cfun_tuple_slice), JANET_CORE_REG("tuple/type", cfun_tuple_type), JANET_CORE_REG("tuple/sourcemap", cfun_tuple_sourcemap), JANET_CORE_REG("tuple/setmap", cfun_tuple_setmap), JANET_CORE_REG("tuple/join", cfun_tuple_join), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, tuple_cfuns); } janet-1.41.2/src/core/util.c000066400000000000000000001112011514534607600155470ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "util.h" #include "state.h" #include "gc.h" #ifdef JANET_WINDOWS #include #else #include #include #include #include #endif #endif #ifdef JANET_WINDOWS #ifdef JANET_DYNAMIC_MODULES #include #ifdef JANET_MSVC #pragma comment (lib, "Psapi.lib") #endif #endif #endif #ifdef JANET_APPLE #include #endif #include /* Base 64 lookup table for digits */ const char janet_base64[65] = "0123456789" "ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyz" "_="; /* The JANET value types in order. These types can be used as * mnemonics instead of a bit pattern for type checking */ const char *const janet_type_names[16] = { "number", "nil", "boolean", "fiber", "string", "symbol", "keyword", "array", "tuple", "table", "struct", "buffer", "function", "cfunction", "abstract", "pointer" }; /* Docstring for signal lists these */ const char *const janet_signal_names[14] = { "ok", "error", "debug", "yield", "user0", "user1", "user2", "user3", "user4", "user5", "user6", "user7", "interrupt", "await" }; /* Docstring for fiber/status lists these */ const char *const janet_status_names[16] = { "dead", "error", "debug", "pending", "user0", "user1", "user2", "user3", "user4", "user5", "user6", "user7", "interrupted", "suspended", "new", "alive" }; uint32_t janet_hash_mix(uint32_t input, uint32_t more) { uint32_t mix1 = (more + 0x9e3779b9 + (input << 6) + (input >> 2)); return input ^ (0x9e3779b9 + (mix1 << 6) + (mix1 >> 2)); } #ifndef JANET_PRF int32_t janet_string_calchash(const uint8_t *str, int32_t len) { if (NULL == str || len == 0) return 5381; const uint8_t *end = str + len; uint32_t hash = 5381; while (str < end) hash = (hash << 5) + hash + *str++; hash = janet_hash_mix(hash, (uint32_t) len); return (int32_t) hash; } #else /* Public domain siphash implementation sourced from: https://raw.githubusercontent.com/veorq/SipHash/master/halfsiphash.c We have made a few alterations, such as hardcoding the output size and then removing dead code. */ #define cROUNDS 2 #define dROUNDS 4 #define ROTL(x, b) (uint32_t)(((x) << (b)) | ((x) >> (32 - (b)))) #define U8TO32_LE(p) \ (((uint32_t)((p)[0])) | ((uint32_t)((p)[1]) << 8) | \ ((uint32_t)((p)[2]) << 16) | ((uint32_t)((p)[3]) << 24)) #define SIPROUND \ do { \ v0 += v1; \ v1 = ROTL(v1, 5); \ v1 ^= v0; \ v0 = ROTL(v0, 16); \ v2 += v3; \ v3 = ROTL(v3, 8); \ v3 ^= v2; \ v0 += v3; \ v3 = ROTL(v3, 7); \ v3 ^= v0; \ v2 += v1; \ v1 = ROTL(v1, 13); \ v1 ^= v2; \ v2 = ROTL(v2, 16); \ } while (0) static uint32_t halfsiphash(const uint8_t *in, const size_t inlen, const uint8_t *k) { uint32_t v0 = 0; uint32_t v1 = 0; uint32_t v2 = UINT32_C(0x6c796765); uint32_t v3 = UINT32_C(0x74656462); uint32_t k0 = U8TO32_LE(k); uint32_t k1 = U8TO32_LE(k + 4); uint32_t m; int i; const uint8_t *end = in + inlen - (inlen % sizeof(uint32_t)); const int left = inlen & 3; uint32_t b = ((uint32_t)inlen) << 24; v3 ^= k1; v2 ^= k0; v1 ^= k1; v0 ^= k0; for (; in != end; in += 4) { m = U8TO32_LE(in); v3 ^= m; for (i = 0; i < cROUNDS; ++i) SIPROUND; v0 ^= m; } switch (left) { case 3: b |= ((uint32_t)in[2]) << 16; /* fallthrough */ case 2: b |= ((uint32_t)in[1]) << 8; /* fallthrough */ case 1: b |= ((uint32_t)in[0]); break; case 0: break; } v3 ^= b; for (i = 0; i < cROUNDS; ++i) SIPROUND; v0 ^= b; v2 ^= 0xff; for (i = 0; i < dROUNDS; ++i) SIPROUND; b = v1 ^ v3; return b; } /* end of siphash */ static uint8_t hash_key[JANET_HASH_KEY_SIZE] = {0}; void janet_init_hash_key(uint8_t new_key[JANET_HASH_KEY_SIZE]) { memcpy(hash_key, new_key, sizeof(hash_key)); } /* Calculate hash for string */ int32_t janet_string_calchash(const uint8_t *str, int32_t len) { uint32_t hash; hash = halfsiphash(str, len, hash_key); return (int32_t)hash; } #endif /* Computes hash of an array of values */ int32_t janet_array_calchash(const Janet *array, int32_t len) { const Janet *end = array + len; uint32_t hash = 33; while (array < end) { hash = janet_hash_mix(hash, janet_hash(*array++)); } return (int32_t) hash; } /* Computes hash of an array of values */ int32_t janet_kv_calchash(const JanetKV *kvs, int32_t len) { const JanetKV *end = kvs + len; uint32_t hash = 33; while (kvs < end) { hash = janet_hash_mix(hash, janet_hash(kvs->key)); hash = janet_hash_mix(hash, janet_hash(kvs->value)); kvs++; } return (int32_t) hash; } /* Calculate next power of 2. May overflow. If n is 0, * will return 0. */ int32_t janet_tablen(int32_t n) { if (n < 0) return 0; n |= n >> 1; n |= n >> 2; n |= n >> 4; n |= n >> 8; n |= n >> 16; return n + 1; } /* Avoid some undefined behavior that was common in the code base. */ void safe_memcpy(void *dest, const void *src, size_t len) { if (!len) return; memcpy(dest, src, len); } /* Helper to find a value in a Janet struct or table. Returns the bucket * containing the key, or the first empty bucket if there is no such key. */ const JanetKV *janet_dict_find(const JanetKV *buckets, int32_t cap, Janet key) { int32_t index = janet_maphash(cap, janet_hash(key)); int32_t i; const JanetKV *first_bucket = NULL; /* Higher half */ for (i = index; i < cap; i++) { const JanetKV *kv = buckets + i; if (janet_checktype(kv->key, JANET_NIL)) { if (janet_checktype(kv->value, JANET_NIL)) { return kv; } else if (NULL == first_bucket) { first_bucket = kv; } } else if (janet_equals(kv->key, key)) { return buckets + i; } } /* Lower half */ for (i = 0; i < index; i++) { const JanetKV *kv = buckets + i; if (janet_checktype(kv->key, JANET_NIL)) { if (janet_checktype(kv->value, JANET_NIL)) { return kv; } else if (NULL == first_bucket) { first_bucket = kv; } } else if (janet_equals(kv->key, key)) { return buckets + i; } } return first_bucket; } /* Helper to find a keyword, symbol, or string in a Janet struct or table without allocating * memory or needing to find interned symbols */ const JanetKV *janet_dict_find_keyword( const JanetKV *buckets, int32_t cap, const uint8_t *cstr, int32_t cstr_len) { int32_t hash = janet_string_calchash(cstr, cstr_len); int32_t index = janet_maphash(cap, hash); int32_t i; const JanetKV *first_bucket = NULL; /* Higher half */ for (i = index; i < cap; i++) { const JanetKV *kv = buckets + i; if (janet_checktype(kv->key, JANET_NIL)) { if (janet_checktype(kv->value, JANET_NIL)) { return kv; } else if (NULL == first_bucket) { first_bucket = kv; } } else if (janet_checktype(kv->key, JANET_KEYWORD)) { /* Works for symbol and keyword, too */ JanetString str = janet_unwrap_string(kv->key); int32_t len = janet_string_length(str); if (hash == janet_string_hash(str) && len == cstr_len && !memcmp(str, cstr, len)) { return buckets + i; } } } /* Lower half */ for (i = 0; i < index; i++) { const JanetKV *kv = buckets + i; if (janet_checktype(kv->key, JANET_NIL)) { if (janet_checktype(kv->value, JANET_NIL)) { return kv; } else if (NULL == first_bucket) { first_bucket = kv; } } else if (janet_checktype(kv->key, JANET_KEYWORD)) { /* Works for symbol and keyword, too */ JanetString str = janet_unwrap_string(kv->key); int32_t len = janet_string_length(str); if (hash == janet_string_hash(str) && len == cstr_len && !memcmp(str, cstr, len)) { return buckets + i; } } } return first_bucket; } /* Get a value from a janet struct or table. */ Janet janet_dictionary_get(const JanetKV *data, int32_t cap, Janet key) { const JanetKV *kv = janet_dict_find(data, cap, key); if (kv && !janet_checktype(kv->key, JANET_NIL)) { return kv->value; } return janet_wrap_nil(); } /* Iterate through a struct or dictionary generically */ const JanetKV *janet_dictionary_next(const JanetKV *kvs, int32_t cap, const JanetKV *kv) { const JanetKV *end = kvs + cap; kv = (kv == NULL) ? kvs : kv + 1; while (kv < end) { if (!janet_checktype(kv->key, JANET_NIL)) return kv; kv++; } return NULL; } /* Compare a janet string with a cstring. More efficient than loading * c string as a janet string. */ int janet_cstrcmp(const uint8_t *str, const char *other) { int32_t len = janet_string_length(str); int32_t index; for (index = 0; index < len; index++) { uint8_t c = str[index]; uint8_t k = ((const uint8_t *)other)[index]; if (c < k) return -1; if (c > k) return 1; if (k == '\0') break; } return (other[index] == '\0') ? 0 : -1; } /* Do a binary search on a static array of structs. Each struct must * have a string as its first element, and the struct must be sorted * lexicographically by that element. */ const void *janet_strbinsearch( const void *tab, size_t tabcount, size_t itemsize, const uint8_t *key) { size_t low = 0; size_t hi = tabcount; const char *t = (const char *)tab; while (low < hi) { size_t mid = low + ((hi - low) / 2); const char **item = (const char **)(t + mid * itemsize); const char *name = *item; int comp = janet_cstrcmp(key, name); if (comp < 0) { hi = mid; } else if (comp > 0) { low = mid + 1; } else { return (const void *)item; } } return NULL; } /* Add sourcemapping and documentation to a binding table */ static void janet_add_meta(JanetTable *table, const char *doc, const char *source_file, int32_t source_line) { if (doc) { janet_table_put(table, janet_ckeywordv("doc"), janet_cstringv(doc)); } if (source_file && source_line) { Janet triple[3]; triple[0] = janet_cstringv(source_file); triple[1] = janet_wrap_integer(source_line); triple[2] = janet_wrap_integer(1); Janet value = janet_wrap_tuple(janet_tuple_n(triple, 3)); janet_table_put(table, janet_ckeywordv("source-map"), value); } } /* Add a def to an environment */ void janet_def_sm(JanetTable *env, const char *name, Janet val, const char *doc, const char *source_file, int32_t source_line) { JanetTable *subt = janet_table(2); janet_table_put(subt, janet_ckeywordv("value"), val); janet_add_meta(subt, doc, source_file, source_line); janet_table_put(env, janet_csymbolv(name), janet_wrap_table(subt)); } void janet_def(JanetTable *env, const char *name, Janet value, const char *doc) { janet_def_sm(env, name, value, doc, NULL, 0); } /* Add a var to the environment */ void janet_var_sm(JanetTable *env, const char *name, Janet val, const char *doc, const char *source_file, int32_t source_line) { JanetArray *array = janet_array(1); JanetTable *subt = janet_table(2); janet_array_push(array, val); janet_table_put(subt, janet_ckeywordv("ref"), janet_wrap_array(array)); janet_add_meta(subt, doc, source_file, source_line); janet_table_put(env, janet_csymbolv(name), janet_wrap_table(subt)); } void janet_var(JanetTable *env, const char *name, Janet val, const char *doc) { janet_var_sm(env, name, val, doc, NULL, 0); } /* Registry functions */ /* Put the registry in sorted order. */ static void janet_registry_sort(void) { for (size_t i = 1; i < janet_vm.registry_count; i++) { JanetCFunRegistry reg = janet_vm.registry[i]; size_t j; for (j = i; j > 0; j--) { if ((void *)(janet_vm.registry[j - 1].cfun) < (void *)(reg.cfun)) break; janet_vm.registry[j] = janet_vm.registry[j - 1]; } janet_vm.registry[j] = reg; } janet_vm.registry_dirty = 0; } void janet_registry_put( JanetCFunction key, const char *name, const char *name_prefix, const char *source_file, int32_t source_line) { if (janet_vm.registry_count == janet_vm.registry_cap) { size_t newcap = (janet_vm.registry_count + 1) * 2; /* Size it nicely with core by default */ if (newcap < 512) { newcap = 512; } void *newmem = janet_realloc(janet_vm.registry, newcap * sizeof(JanetCFunRegistry)); if (NULL == newmem) { JANET_OUT_OF_MEMORY; } janet_vm.registry = newmem; janet_vm.registry_cap = newcap; } JanetCFunRegistry value = { key, name, name_prefix, source_file, source_line }; janet_vm.registry[janet_vm.registry_count++] = value; janet_vm.registry_dirty = 1; } JanetCFunRegistry *janet_registry_get(JanetCFunction key) { if (janet_vm.registry_dirty) { janet_registry_sort(); } for (size_t i = 0; i < janet_vm.registry_count; i++) { if (janet_vm.registry[i].cfun == key) { return janet_vm.registry + i; } } JanetCFunRegistry *lo = janet_vm.registry; JanetCFunRegistry *hi = lo + janet_vm.registry_count; while (lo < hi) { JanetCFunRegistry *mid = lo + (hi - lo) / 2; if (mid->cfun == key) { return mid; } if ((void *)(mid->cfun) > (void *)(key)) { hi = mid; } else { lo = mid + 1; } } return NULL; } typedef struct { char *buf; size_t plen; } NameBuf; static void namebuf_init(NameBuf *namebuf, const char *prefix) { size_t plen = strlen(prefix); namebuf->plen = plen; namebuf->buf = janet_smalloc(namebuf->plen + 256); if (NULL == namebuf->buf) { JANET_OUT_OF_MEMORY; } memcpy(namebuf->buf, prefix, plen); namebuf->buf[plen] = '/'; } static void namebuf_deinit(NameBuf *namebuf) { janet_sfree(namebuf->buf); } static char *namebuf_name(NameBuf *namebuf, const char *suffix) { size_t slen = strlen(suffix); namebuf->buf = janet_srealloc(namebuf->buf, namebuf->plen + 2 + slen); if (NULL == namebuf->buf) { JANET_OUT_OF_MEMORY; } memcpy(namebuf->buf + namebuf->plen + 1, suffix, slen); namebuf->buf[namebuf->plen + 1 + slen] = '\0'; return (char *)(namebuf->buf); } void janet_cfuns(JanetTable *env, const char *regprefix, const JanetReg *cfuns) { while (cfuns->name) { Janet fun = janet_wrap_cfunction(cfuns->cfun); if (env) janet_def(env, cfuns->name, fun, cfuns->documentation); janet_registry_put(cfuns->cfun, cfuns->name, regprefix, NULL, 0); cfuns++; } } void janet_cfuns_ext(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns) { while (cfuns->name) { Janet fun = janet_wrap_cfunction(cfuns->cfun); if (env) janet_def_sm(env, cfuns->name, fun, cfuns->documentation, cfuns->source_file, cfuns->source_line); janet_registry_put(cfuns->cfun, cfuns->name, regprefix, cfuns->source_file, cfuns->source_line); cfuns++; } } void janet_cfuns_prefix(JanetTable *env, const char *regprefix, const JanetReg *cfuns) { NameBuf nb; if (env) namebuf_init(&nb, regprefix); while (cfuns->name) { Janet fun = janet_wrap_cfunction(cfuns->cfun); if (env) janet_def(env, namebuf_name(&nb, cfuns->name), fun, cfuns->documentation); janet_registry_put(cfuns->cfun, cfuns->name, regprefix, NULL, 0); cfuns++; } if (env) namebuf_deinit(&nb); } void janet_cfuns_ext_prefix(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns) { NameBuf nb; if (env) namebuf_init(&nb, regprefix); while (cfuns->name) { Janet fun = janet_wrap_cfunction(cfuns->cfun); if (env) janet_def_sm(env, namebuf_name(&nb, cfuns->name), fun, cfuns->documentation, cfuns->source_file, cfuns->source_line); janet_registry_put(cfuns->cfun, cfuns->name, regprefix, cfuns->source_file, cfuns->source_line); cfuns++; } if (env) namebuf_deinit(&nb); } /* Register a value in the global registry */ void janet_register(const char *name, JanetCFunction cfun) { janet_registry_put(cfun, name, NULL, NULL, 0); } /* Abstract type introspection */ void janet_register_abstract_type(const JanetAbstractType *at) { Janet sym = janet_csymbolv(at->name); Janet check = janet_table_get(janet_vm.abstract_registry, sym); if (!janet_checktype(check, JANET_NIL) && at != janet_unwrap_pointer(check)) { janet_panicf("cannot register abstract type %s, " "a type with the same name exists", at->name); } janet_table_put(janet_vm.abstract_registry, sym, janet_wrap_pointer((void *) at)); } const JanetAbstractType *janet_get_abstract_type(Janet key) { Janet wrapped = janet_table_get(janet_vm.abstract_registry, key); if (janet_checktype(wrapped, JANET_NIL)) { return NULL; } return (JanetAbstractType *)(janet_unwrap_pointer(wrapped)); } #ifndef JANET_BOOTSTRAP void janet_core_def_sm(JanetTable *env, const char *name, Janet x, const void *p, const void *sf, int32_t sl) { (void) sf; (void) sl; (void) p; Janet key = janet_csymbolv(name); janet_table_put(env, key, x); if (janet_checktype(x, JANET_CFUNCTION)) { janet_registry_put(janet_unwrap_cfunction(x), name, NULL, NULL, 0); } } void janet_core_cfuns_ext(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns) { (void) regprefix; while (cfuns->name) { Janet fun = janet_wrap_cfunction(cfuns->cfun); janet_table_put(env, janet_csymbolv(cfuns->name), fun); janet_registry_put(cfuns->cfun, cfuns->name, regprefix, cfuns->source_file, cfuns->source_line); cfuns++; } } #endif JanetBinding janet_binding_from_entry(Janet entry) { JanetTable *entry_table; JanetBinding binding = { JANET_BINDING_NONE, janet_wrap_nil(), JANET_BINDING_DEP_NONE }; /* Check environment for entry */ if (!janet_checktype(entry, JANET_TABLE)) return binding; entry_table = janet_unwrap_table(entry); Janet deprecate = janet_table_get_keyword(entry_table, "deprecated"); int macro = janet_truthy(janet_table_get_keyword(entry_table, "macro")); Janet value = janet_table_get_keyword(entry_table, "value"); Janet ref = janet_table_get_keyword(entry_table, "ref"); if (janet_checktype(deprecate, JANET_KEYWORD)) { JanetKeyword depkw = janet_unwrap_keyword(deprecate); if (!janet_cstrcmp(depkw, "relaxed")) { binding.deprecation = JANET_BINDING_DEP_RELAXED; } else if (!janet_cstrcmp(depkw, "normal")) { binding.deprecation = JANET_BINDING_DEP_NORMAL; } else if (!janet_cstrcmp(depkw, "strict")) { binding.deprecation = JANET_BINDING_DEP_STRICT; } } else if (!janet_checktype(deprecate, JANET_NIL)) { binding.deprecation = JANET_BINDING_DEP_NORMAL; } int ref_is_valid = janet_checktype(ref, JANET_ARRAY); int redef = ref_is_valid && janet_truthy(janet_table_get_keyword(entry_table, "redef")); if (macro) { binding.value = redef ? ref : value; binding.type = redef ? JANET_BINDING_DYNAMIC_MACRO : JANET_BINDING_MACRO; return binding; } if (ref_is_valid) { binding.value = ref; binding.type = redef ? JANET_BINDING_DYNAMIC_DEF : JANET_BINDING_VAR; } else { binding.value = value; binding.type = JANET_BINDING_DEF; } return binding; } /* If the value at the given address can be coerced to a byte view, return that byte view. If it can't, replace the value at the address with the result of janet_to_string, and return a byte view over that string. */ static JanetByteView memoize_byte_view(Janet *value) { JanetByteView result; if (!janet_bytes_view(*value, &result.bytes, &result.len)) { JanetString str = janet_to_string(*value); *value = janet_wrap_string(str); result.bytes = str; result.len = janet_string_length(str); } return result; } static JanetByteView to_byte_view(Janet value) { JanetByteView result; if (!janet_bytes_view(value, &result.bytes, &result.len)) { JanetString str = janet_to_string(value); result.bytes = str; result.len = janet_string_length(str); } return result; } JanetByteView janet_text_substitution( Janet *subst, const uint8_t *bytes, uint32_t len, JanetArray *extra_argv) { int32_t extra_argc = extra_argv == NULL ? 0 : extra_argv->count; JanetType type = janet_type(*subst); switch (type) { case JANET_FUNCTION: case JANET_CFUNCTION: { int32_t argc = 1 + extra_argc; Janet *argv = janet_tuple_begin(argc); argv[0] = janet_stringv(bytes, len); for (int32_t i = 0; i < extra_argc; i++) { argv[i + 1] = extra_argv->data[i]; } janet_tuple_end(argv); if (type == JANET_FUNCTION) { return to_byte_view(janet_call(janet_unwrap_function(*subst), argc, argv)); } else { return to_byte_view(janet_unwrap_cfunction(*subst)(argc, argv)); } } default: return memoize_byte_view(subst); } } JanetBinding janet_resolve_ext(JanetTable *env, const uint8_t *sym) { Janet entry = janet_table_get(env, janet_wrap_symbol(sym)); return janet_binding_from_entry(entry); } JanetBindingType janet_resolve(JanetTable *env, const uint8_t *sym, Janet *out) { JanetBinding binding = janet_resolve_ext(env, sym); if (binding.type == JANET_BINDING_DYNAMIC_DEF || binding.type == JANET_BINDING_DYNAMIC_MACRO) { *out = janet_array_peek(janet_unwrap_array(binding.value)); } else { *out = binding.value; } return binding.type; } /* Resolve a symbol in the core environment. */ Janet janet_resolve_core(const char *name) { JanetTable *env = janet_core_env(NULL); Janet out = janet_wrap_nil(); janet_resolve(env, janet_csymbol(name), &out); return out; } /* Read both tuples and arrays as c pointers + int32_t length. Return 1 if the * view can be constructed, 0 if an invalid type. */ int janet_indexed_view(Janet seq, const Janet **data, int32_t *len) { if (janet_checktype(seq, JANET_ARRAY)) { *data = janet_unwrap_array(seq)->data; *len = janet_unwrap_array(seq)->count; return 1; } else if (janet_checktype(seq, JANET_TUPLE)) { *data = janet_unwrap_tuple(seq); *len = janet_tuple_length(janet_unwrap_tuple(seq)); return 1; } return 0; } /* Read both strings and buffer as unsigned character array + int32_t len. * Returns 1 if the view can be constructed and 0 if the type is invalid. */ int janet_bytes_view(Janet str, const uint8_t **data, int32_t *len) { JanetType t = janet_type(str); if (t == JANET_STRING || t == JANET_SYMBOL || t == JANET_KEYWORD) { *data = janet_unwrap_string(str); *len = janet_string_length(janet_unwrap_string(str)); return 1; } else if (t == JANET_BUFFER) { *data = janet_unwrap_buffer(str)->data; *len = janet_unwrap_buffer(str)->count; return 1; } else if (t == JANET_ABSTRACT) { void *abst = janet_unwrap_abstract(str); const JanetAbstractType *atype = janet_abstract_type(abst); if (NULL == atype->bytes) { return 0; } JanetByteView view = atype->bytes(abst, janet_abstract_size(abst)); *data = view.bytes; *len = view.len; return 1; } return 0; } /* Read both structs and tables as the entries of a hashtable with * identical structure. Returns 1 if the view can be constructed and * 0 if the type is invalid. */ int janet_dictionary_view(Janet tab, const JanetKV **data, int32_t *len, int32_t *cap) { if (janet_checktype(tab, JANET_TABLE)) { *data = janet_unwrap_table(tab)->data; *cap = janet_unwrap_table(tab)->capacity; *len = janet_unwrap_table(tab)->count; return 1; } else if (janet_checktype(tab, JANET_STRUCT)) { *data = janet_unwrap_struct(tab); *cap = janet_struct_capacity(janet_unwrap_struct(tab)); *len = janet_struct_length(janet_unwrap_struct(tab)); return 1; } return 0; } int janet_checkint(Janet x) { if (!janet_checktype(x, JANET_NUMBER)) return 0; double dval = janet_unwrap_number(x); return janet_checkintrange(dval); } int janet_checkuint(Janet x) { if (!janet_checktype(x, JANET_NUMBER)) return 0; double dval = janet_unwrap_number(x); return janet_checkuintrange(dval); } int janet_checkint64(Janet x) { if (!janet_checktype(x, JANET_NUMBER)) return 0; double dval = janet_unwrap_number(x); return janet_checkint64range(dval); } int janet_checkuint64(Janet x) { if (!janet_checktype(x, JANET_NUMBER)) return 0; double dval = janet_unwrap_number(x); return janet_checkuint64range(dval); } int janet_checkint16(Janet x) { if (!janet_checktype(x, JANET_NUMBER)) return 0; double dval = janet_unwrap_number(x); return janet_checkint16range(dval); } int janet_checkuint16(Janet x) { if (!janet_checktype(x, JANET_NUMBER)) return 0; double dval = janet_unwrap_number(x); return janet_checkuint16range(dval); } int janet_checksize(Janet x) { if (!janet_checktype(x, JANET_NUMBER)) return 0; double dval = janet_unwrap_number(x); if (dval != (double)((size_t) dval)) return 0; #ifdef JANET_PLAN9 return dval <= SIZE_MAX; #else if (SIZE_MAX > JANET_INTMAX_INT64) { return dval <= JANET_INTMAX_INT64; } else { return dval <= SIZE_MAX; } #endif } JanetTable *janet_get_core_table(const char *name) { JanetTable *env = janet_core_env(NULL); Janet out = janet_wrap_nil(); JanetBindingType bt = janet_resolve(env, janet_csymbol(name), &out); if (bt == JANET_BINDING_NONE) return NULL; if (!janet_checktype(out, JANET_TABLE)) return NULL; return janet_unwrap_table(out); } /* Sort keys of a dictionary type */ int32_t janet_sorted_keys(const JanetKV *dict, int32_t cap, int32_t *index_buffer) { /* First, put populated indices into index_buffer */ int32_t next_index = 0; for (int32_t i = 0; i < cap; i++) { if (!janet_checktype(dict[i].key, JANET_NIL)) { index_buffer[next_index++] = i; } } /* Next, sort those (simple insertion sort here for now) */ for (int32_t i = 1; i < next_index; i++) { int32_t index_to_insert = index_buffer[i]; Janet lhs = dict[index_to_insert].key; for (int32_t j = i - 1; j >= 0; j--) { index_buffer[j + 1] = index_buffer[j]; Janet rhs = dict[index_buffer[j]].key; if (janet_compare(lhs, rhs) >= 0) { index_buffer[j + 1] = index_to_insert; break; } else if (j == 0) { index_buffer[0] = index_to_insert; } } } /* Return number of indices found */ return next_index; } /* Clock shims for various platforms */ #ifdef JANET_GETTIME #ifdef JANET_WINDOWS #include int janet_gettime(struct timespec *spec, enum JanetTimeSource source) { if (source == JANET_TIME_REALTIME) { FILETIME ftime; GetSystemTimeAsFileTime(&ftime); int64_t wintime = (int64_t)(ftime.dwLowDateTime) | ((int64_t)(ftime.dwHighDateTime) << 32); /* Windows epoch is January 1, 1601 apparently */ wintime -= 116444736000000000LL; spec->tv_sec = wintime / 10000000LL; /* Resolution is 100 nanoseconds. */ spec->tv_nsec = wintime % 10000000LL * 100; } else if (source == JANET_TIME_MONOTONIC) { LARGE_INTEGER count; LARGE_INTEGER perf_freq; QueryPerformanceCounter(&count); QueryPerformanceFrequency(&perf_freq); spec->tv_sec = count.QuadPart / perf_freq.QuadPart; spec->tv_nsec = (long)((count.QuadPart % perf_freq.QuadPart) * 1000000000 / perf_freq.QuadPart); } else if (source == JANET_TIME_CPUTIME) { FILETIME creationTime, exitTime, kernelTime, userTime; GetProcessTimes(GetCurrentProcess(), &creationTime, &exitTime, &kernelTime, &userTime); int64_t tmp = ((int64_t)userTime.dwHighDateTime << 32) + userTime.dwLowDateTime; spec->tv_sec = tmp / 10000000LL; spec->tv_nsec = tmp % 10000000LL * 100; } return 0; } /* clock_gettime() wasn't available on Mac until 10.12. */ #elif defined(JANET_APPLE) && !defined(MAC_OS_X_VERSION_10_12) #include #include int janet_gettime(struct timespec *spec, enum JanetTimeSource source) { if (source == JANET_TIME_CPUTIME) { clock_t tmp = clock(); spec->tv_sec = tmp / CLOCKS_PER_SEC; spec->tv_nsec = ((tmp - (spec->tv_sec * CLOCKS_PER_SEC)) * 1000000000) / CLOCKS_PER_SEC; } else { clock_serv_t cclock; mach_timespec_t mts; clock_id_t cid = CALENDAR_CLOCK; if (source == JANET_TIME_REALTIME) { cid = CALENDAR_CLOCK; } else if (source == JANET_TIME_MONOTONIC) { cid = SYSTEM_CLOCK; } host_get_clock_service(mach_host_self(), cid, &cclock); clock_get_time(cclock, &mts); mach_port_deallocate(mach_task_self(), cclock); spec->tv_sec = mts.tv_sec; spec->tv_nsec = mts.tv_nsec; } return 0; } #else int janet_gettime(struct timespec *spec, enum JanetTimeSource source) { clockid_t cid = CLOCK_REALTIME; if (source == JANET_TIME_REALTIME) { cid = CLOCK_REALTIME; } else if (source == JANET_TIME_MONOTONIC) { cid = CLOCK_MONOTONIC; } else if (source == JANET_TIME_CPUTIME) { cid = CLOCK_PROCESS_CPUTIME_ID; } return clock_gettime(cid, spec); } #endif #endif /* Better strerror (thread-safe if available) */ const char *janet_strerror(int e) { #ifdef JANET_WINDOWS /* Microsoft strerror seems sane here and is thread safe by default */ return strerror(e); #elif defined(__GLIBC__) /* See https://linux.die.net/man/3/strerror_r */ return strerror_r(e, janet_vm.strerror_buf, sizeof(janet_vm.strerror_buf)); #else strerror_r(e, janet_vm.strerror_buf, sizeof(janet_vm.strerror_buf)); return janet_vm.strerror_buf; #endif } /* Setting C99 standard makes this not available, but it should * work/link properly if we detect a BSD */ #if defined(JANET_BSD) || defined(MAC_OS_X_VERSION_10_7) void arc4random_buf(void *buf, size_t nbytes); #endif int janet_cryptorand(uint8_t *out, size_t n) { #ifndef JANET_NO_CRYPTORAND #ifdef JANET_WINDOWS for (size_t i = 0; i < n; i += sizeof(unsigned int)) { unsigned int v; if (rand_s(&v)) return -1; for (int32_t j = 0; (j < (int32_t) sizeof(unsigned int)) && (i + j < n); j++) { out[i + j] = v & 0xff; v = v >> 8; } } return 0; #elif defined(JANET_BSD) || defined(MAC_OS_X_VERSION_10_7) arc4random_buf(out, n); return 0; #else /* We should be able to call getrandom on linux, but it doesn't seem to be uniformly supported on linux distros. On Mac, arc4random_buf wasn't available on until 10.7. In these cases, use this fallback path for now... */ int rc; int randfd; RETRY_EINTR(randfd, open("/dev/urandom", O_RDONLY | O_CLOEXEC)); if (randfd < 0) return -1; while (n > 0) { ssize_t nread; RETRY_EINTR(nread, read(randfd, out, n)); if (nread <= 0) { RETRY_EINTR(rc, close(randfd)); return -1; } out += nread; n -= nread; } RETRY_EINTR(rc, close(randfd)); return 0; #endif #else (void) out; (void) n; return -1; #endif } /* Dynamic library loading */ char *get_processed_name(const char *name) { if (name[0] == '.') return (char *) name; const char *c; for (c = name; *c; c++) { if (*c == '/') return (char *) name; } size_t l = (size_t)(c - name); char *ret = janet_malloc(l + 3); if (NULL == ret) { JANET_OUT_OF_MEMORY; } ret[0] = '.'; ret[1] = '/'; memcpy(ret + 2, name, l + 1); return ret; } #if defined(JANET_NO_DYNAMIC_MODULES) const char *error_clib(void) { return "dynamic modules not supported"; } #else #if defined(JANET_WINDOWS) static char error_clib_buf[256]; char *error_clib(void) { FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, NULL, GetLastError(), MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), error_clib_buf, sizeof(error_clib_buf), NULL); error_clib_buf[strlen(error_clib_buf) - 1] = '\0'; return error_clib_buf; } Clib load_clib(const char *name) { if (name == NULL) { return GetModuleHandle(NULL); } else { return LoadLibrary(name); } } void free_clib(HINSTANCE clib) { if (clib != GetModuleHandle(NULL)) { FreeLibrary(clib); } } void *symbol_clib(HINSTANCE clib, const char *sym) { if (clib != GetModuleHandle(NULL)) { return GetProcAddress(clib, sym); } else { /* Look up symbols from all loaded modules */ HMODULE hMods[1024]; DWORD needed = 0; if (EnumProcessModules(GetCurrentProcess(), hMods, sizeof(hMods), &needed)) { needed /= sizeof(HMODULE); for (DWORD i = 0; i < needed; i++) { void *address = GetProcAddress(hMods[i], sym); if (NULL != address) { return address; } } } else { janet_panicf("ffi: %s", error_clib()); } return NULL; } } #endif #endif /* Alloc function macro fills */ void *(janet_malloc)(size_t size) { return janet_malloc(size); } void (janet_free)(void *ptr) { janet_free(ptr); } void *(janet_calloc)(size_t nmemb, size_t size) { return janet_calloc(nmemb, size); } void *(janet_realloc)(void *ptr, size_t size) { return janet_realloc(ptr, size); } janet-1.41.2/src/core/util.h000066400000000000000000000156071514534607600155710ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_UTIL_H_defined #define JANET_UTIL_H_defined #ifndef JANET_AMALG #include "features.h" #include #include "state.h" #endif #include #include #include #include #include #ifdef JANET_EV #ifndef JANET_WINDOWS #include #endif #endif #if !defined(JANET_REDUCED_OS) || !defined(JANET_SINGLE_THREADED) #include #define JANET_GETTIME #endif /* Handle runtime errors */ #ifndef JANET_EXIT #include #define JANET_EXIT(m) do { \ fprintf(stderr, "janet internal error at line %d in file %s: %s\n",\ __LINE__,\ __FILE__,\ (m));\ abort();\ } while (0) #endif #define JANET_MARSHAL_DECREF 0x40000 #define janet_assert(c, m) do { \ if (!(c)) JANET_EXIT((m)); \ } while (0) /* Utils */ uint32_t janet_hash_mix(uint32_t input, uint32_t more); #define janet_maphash(cap, hash) ((uint32_t)(hash) & (cap - 1)) int janet_valid_utf8(const uint8_t *str, int32_t len); int janet_is_symbol_char(uint8_t c); extern const char janet_base64[65]; int32_t janet_array_calchash(const Janet *array, int32_t len); int32_t janet_kv_calchash(const JanetKV *kvs, int32_t len); int32_t janet_string_calchash(const uint8_t *str, int32_t len); int32_t janet_tablen(int32_t n); void safe_memcpy(void *dest, const void *src, size_t len); void janet_buffer_push_types(JanetBuffer *buffer, int types); const JanetKV *janet_dict_find(const JanetKV *buckets, int32_t cap, Janet key); void janet_memempty(JanetKV *mem, int32_t count); void *janet_memalloc_empty(int32_t count); JanetTable *janet_get_core_table(const char *name); void janet_def_addflags(JanetFuncDef *def); void janet_buffer_dtostr(JanetBuffer *buffer, double x); const char *janet_strerror(int e); const void *janet_strbinsearch( const void *tab, size_t tabcount, size_t itemsize, const uint8_t *key); void janet_buffer_format( JanetBuffer *b, const char *strfrmt, int32_t argstart, int32_t argc, Janet *argv); Janet janet_next_impl(Janet ds, Janet key, int is_interpreter); JanetBinding janet_binding_from_entry(Janet entry); JanetByteView janet_text_substitution( Janet *subst, const uint8_t *bytes, uint32_t len, JanetArray *extra_args); const JanetKV *janet_dict_find_keyword( const JanetKV *buckets, int32_t cap, const uint8_t *cstr, int32_t cstr_len); Janet janet_table_get_keyword(JanetTable *t, const char *keyword); /* Registry functions */ void janet_registry_put( JanetCFunction key, const char *name, const char *name_prefix, const char *source_file, int32_t source_line); JanetCFunRegistry *janet_registry_get(JanetCFunction key); /* Inside the janet core, defining globals is different * at bootstrap time and normal runtime */ #ifdef JANET_BOOTSTRAP #define JANET_CORE_REG JANET_REG #define JANET_CORE_FN JANET_FN #define JANET_CORE_DEF JANET_DEF #define janet_core_def_sm janet_def_sm #define janet_core_cfuns_ext janet_cfuns_ext #else #define JANET_CORE_REG JANET_REG_S #define JANET_CORE_FN JANET_FN_S #define JANET_CORE_DEF(ENV, NAME, X, DOC) janet_core_def_sm(ENV, NAME, X, DOC, NULL, 0) void janet_core_def_sm(JanetTable *env, const char *name, Janet x, const void *p, const void *sf, int32_t sl); void janet_core_cfuns_ext(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns); #endif /* Clock gettime */ #ifdef JANET_GETTIME enum JanetTimeSource { JANET_TIME_REALTIME, JANET_TIME_MONOTONIC, JANET_TIME_CPUTIME }; int janet_gettime(struct timespec *spec, enum JanetTimeSource source); #endif /* strdup */ #ifdef JANET_WINDOWS #define strdup(x) _strdup(x) #endif /* Use LoadLibrary on windows or dlopen on posix to load dynamic libraries * with native code. */ #if defined(JANET_NO_DYNAMIC_MODULES) typedef int Clib; #define load_clib(name) ((void) name, 0) #define symbol_clib(lib, sym) ((void) lib, (void) sym, NULL) const char *error_clib(void); #define free_clib(c) ((void) (c), 0) #elif defined(JANET_WINDOWS) #include typedef HINSTANCE Clib; void *symbol_clib(Clib clib, const char *sym); void free_clib(Clib clib); Clib load_clib(const char *name); char *error_clib(void); #else #include typedef void *Clib; #define load_clib(name) dlopen((name), RTLD_NOW) #define free_clib(lib) dlclose((lib)) #define symbol_clib(lib, sym) dlsym((lib), (sym)) #define error_clib dlerror #endif char *get_processed_name(const char *name); #ifdef JANET_PLAN9 #define RETRY_EINTR(RC, CALL) (RC) = CALL; #else #define RETRY_EINTR(RC, CALL) do { (RC) = CALL; } while((RC) < 0 && errno == EINTR) #endif /* Initialize builtin libraries */ void janet_lib_io(JanetTable *env); void janet_lib_math(JanetTable *env); void janet_lib_array(JanetTable *env); void janet_lib_tuple(JanetTable *env); void janet_lib_buffer(JanetTable *env); void janet_lib_table(JanetTable *env); void janet_lib_struct(JanetTable *env); void janet_lib_fiber(JanetTable *env); void janet_lib_os(JanetTable *env); void janet_lib_string(JanetTable *env); void janet_lib_marsh(JanetTable *env); void janet_lib_parse(JanetTable *env); #ifdef JANET_ASSEMBLER void janet_lib_asm(JanetTable *env); #endif void janet_lib_compile(JanetTable *env); void janet_lib_debug(JanetTable *env); #ifdef JANET_PEG void janet_lib_peg(JanetTable *env); #endif #ifdef JANET_INT_TYPES void janet_lib_inttypes(JanetTable *env); #endif #ifdef JANET_NET void janet_lib_net(JanetTable *env); extern const JanetAbstractType janet_address_type; #endif #ifdef JANET_EV void janet_lib_ev(JanetTable *env); void janet_ev_mark(void); void janet_async_start_fiber(JanetFiber *fiber, JanetStream *stream, JanetAsyncMode mode, JanetEVCallback callback, void *state); int janet_make_pipe(JanetHandle handles[2], int mode); #ifdef JANET_FILEWATCH void janet_lib_filewatch(JanetTable *env); #endif #endif #ifdef JANET_FFI void janet_lib_ffi(JanetTable *env); #endif #endif janet-1.41.2/src/core/value.c000066400000000000000000000736721514534607600157310ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include "util.h" #include "state.h" #include "gc.h" #include "fiber.h" #include #endif #include static void push_traversal_node(void *lhs, void *rhs, int32_t index2) { JanetTraversalNode node; node.self = (JanetGCObject *) lhs; node.other = (JanetGCObject *) rhs; node.index = 0; node.index2 = index2; int is_new = janet_vm.traversal_base == NULL; if (is_new || (janet_vm.traversal + 1 >= janet_vm.traversal_top)) { size_t oldsize = is_new ? 0 : (janet_vm.traversal - janet_vm.traversal_base); size_t newsize = 2 * oldsize + 1; if (newsize < 128) { newsize = 128; } JanetTraversalNode *tn = janet_realloc(janet_vm.traversal_base, newsize * sizeof(JanetTraversalNode)); if (tn == NULL) { JANET_OUT_OF_MEMORY; } janet_vm.traversal_base = tn; janet_vm.traversal_top = janet_vm.traversal_base + newsize; janet_vm.traversal = janet_vm.traversal_base + oldsize; } *(++janet_vm.traversal) = node; } /* * Used for travsersing structs and tuples without recursion * Returns: * 0 - next node found * 1 - early stop - lhs < rhs * 2 - no next node found * 3 - early stop - lhs > rhs */ static int traversal_next(Janet *x, Janet *y) { JanetTraversalNode *t = janet_vm.traversal; while (t && t > janet_vm.traversal_base) { JanetGCObject *self = t->self; JanetTupleHead *tself = (JanetTupleHead *)self; JanetStructHead *sself = (JanetStructHead *)self; JanetGCObject *other = t->other; JanetTupleHead *tother = (JanetTupleHead *)other; JanetStructHead *sother = (JanetStructHead *)other; if ((self->flags & JANET_MEM_TYPEBITS) == JANET_MEMORY_TUPLE) { /* Node is a tuple at index t->index */ if (t->index < tself->length && t->index < tother->length) { int32_t index = t->index++; *x = tself->data[index]; *y = tother->data[index]; janet_vm.traversal = t; return 0; } if (t->index2 && tself->length != tother->length) { return tself->length > tother->length ? 3 : 1; } } else { /* Node is a struct at index t->index: if t->index2 is true, we should return the values. */ if (t->index2) { t->index2 = 0; int32_t index = t->index++; *x = sself->data[index].value; *y = sother->data[index].value; janet_vm.traversal = t; return 0; } for (int32_t i = t->index; i < sself->capacity; i++) { t->index2 = 1; *x = sself->data[t->index].key; *y = sother->data[t->index].key; janet_vm.traversal = t; return 0; } /* Traverse prototype */ JanetStruct sproto = sself->proto; JanetStruct oproto = sother->proto; if (sproto && !oproto) return 3; if (!sproto && oproto) return 1; if (oproto && sproto) { *x = janet_wrap_struct(sproto); *y = janet_wrap_struct(oproto); janet_vm.traversal = t - 1; return 0; } } t--; } janet_vm.traversal = t; return 2; } /* * Define a number of functions that can be used internally on ANY Janet. */ Janet janet_next(Janet ds, Janet key) { return janet_next_impl(ds, key, 0); } Janet janet_next_impl(Janet ds, Janet key, int is_interpreter) { JanetType t = janet_type(ds); switch (t) { default: janet_panicf("expected iterable type, got %v", ds); case JANET_TABLE: case JANET_STRUCT: { const JanetKV *start; int32_t cap; if (t == JANET_TABLE) { JanetTable *tab = janet_unwrap_table(ds); cap = tab->capacity; start = tab->data; } else { JanetStruct st = janet_unwrap_struct(ds); cap = janet_struct_capacity(st); start = st; } const JanetKV *end = start + cap; const JanetKV *kv = janet_checktype(key, JANET_NIL) ? start : janet_dict_find(start, cap, key) + 1; while (kv < end) { if (!janet_checktype(kv->key, JANET_NIL)) return kv->key; kv++; } break; } case JANET_STRING: case JANET_KEYWORD: case JANET_SYMBOL: case JANET_BUFFER: case JANET_ARRAY: case JANET_TUPLE: { int32_t i; if (janet_checktype(key, JANET_NIL)) { i = 0; } else if (janet_checkint(key)) { i = janet_unwrap_integer(key) + 1; } else { break; } int32_t len; if (t == JANET_BUFFER) { len = janet_unwrap_buffer(ds)->count; } else if (t == JANET_ARRAY) { len = janet_unwrap_array(ds)->count; } else if (t == JANET_TUPLE) { len = janet_tuple_length(janet_unwrap_tuple(ds)); } else { len = janet_string_length(janet_unwrap_string(ds)); } if (i < len && i >= 0) { return janet_wrap_integer(i); } break; } case JANET_ABSTRACT: { JanetAbstract abst = janet_unwrap_abstract(ds); const JanetAbstractType *at = janet_abstract_type(abst); if (NULL == at->next) break; return at->next(abst, key); } case JANET_FIBER: { JanetFiber *child = janet_unwrap_fiber(ds); Janet retreg; JanetFiberStatus status = janet_fiber_status(child); if (status == JANET_STATUS_ALIVE || status == JANET_STATUS_DEAD || status == JANET_STATUS_ERROR || status == JANET_STATUS_USER0 || status == JANET_STATUS_USER1 || status == JANET_STATUS_USER2 || status == JANET_STATUS_USER3 || status == JANET_STATUS_USER4) { return janet_wrap_nil(); } janet_vm.fiber->child = child; JanetSignal sig = janet_continue(child, janet_wrap_nil(), &retreg); if (sig != JANET_SIGNAL_OK && !(child->flags & (1 << sig))) { if (is_interpreter) { janet_signalv(sig, retreg); } else { janet_vm.fiber->child = NULL; janet_panicv(retreg); } } janet_vm.fiber->child = NULL; if (sig == JANET_SIGNAL_OK || sig == JANET_SIGNAL_ERROR || sig == JANET_SIGNAL_USER0 || sig == JANET_SIGNAL_USER1 || sig == JANET_SIGNAL_USER2 || sig == JANET_SIGNAL_USER3 || sig == JANET_SIGNAL_USER4) { /* Fiber cannot be resumed, so discard last value. */ return janet_wrap_nil(); } else { return janet_wrap_integer(0); } } } return janet_wrap_nil(); } /* Compare two abstract values */ static int janet_compare_abstract(JanetAbstract xx, JanetAbstract yy) { if (xx == yy) return 0; const JanetAbstractType *xt = janet_abstract_type(xx); const JanetAbstractType *yt = janet_abstract_type(yy); if (xt != yt) { return xt > yt ? 1 : -1; } if (xt->compare == NULL) { return xx > yy ? 1 : -1; } return xt->compare(xx, yy); } int janet_equals(Janet x, Janet y) { janet_vm.traversal = janet_vm.traversal_base; do { if (janet_type(x) != janet_type(y)) return 0; switch (janet_type(x)) { case JANET_NIL: break; case JANET_BOOLEAN: if (janet_unwrap_boolean(x) != janet_unwrap_boolean(y)) return 0; break; case JANET_NUMBER: if (janet_unwrap_number(x) != janet_unwrap_number(y)) return 0; break; case JANET_STRING: if (!janet_string_equal(janet_unwrap_string(x), janet_unwrap_string(y))) return 0; break; case JANET_ABSTRACT: if (janet_compare_abstract(janet_unwrap_abstract(x), janet_unwrap_abstract(y))) return 0; break; default: if (janet_unwrap_pointer(x) != janet_unwrap_pointer(y)) return 0; break; case JANET_TUPLE: { const Janet *t1 = janet_unwrap_tuple(x); const Janet *t2 = janet_unwrap_tuple(y); if (t1 == t2) break; if (JANET_TUPLE_FLAG_BRACKETCTOR & (janet_tuple_flag(t1) ^ janet_tuple_flag(t2))) return 0; if (janet_tuple_hash(t1) != janet_tuple_hash(t2)) return 0; if (janet_tuple_length(t1) != janet_tuple_length(t2)) return 0; push_traversal_node(janet_tuple_head(t1), janet_tuple_head(t2), 0); break; } break; case JANET_STRUCT: { const JanetKV *s1 = janet_unwrap_struct(x); const JanetKV *s2 = janet_unwrap_struct(y); if (s1 == s2) break; if (janet_struct_hash(s1) != janet_struct_hash(s2)) return 0; if (janet_struct_length(s1) != janet_struct_length(s2)) return 0; if (janet_struct_proto(s1) && !janet_struct_proto(s2)) return 0; if (!janet_struct_proto(s1) && janet_struct_proto(s2)) return 0; push_traversal_node(janet_struct_head(s1), janet_struct_head(s2), 0); break; } break; } } while (!traversal_next(&x, &y)); return 1; } static uint64_t murmur64(uint64_t h) { h ^= h >> 33; h *= 0xff51afd7ed558ccdUL; h ^= h >> 33; h *= 0xc4ceb9fe1a85ec53UL; h ^= h >> 33; return h; } /* Computes a hash value for a function */ int32_t janet_hash(Janet x) { int32_t hash = 0; switch (janet_type(x)) { case JANET_NIL: hash = 0; break; case JANET_BOOLEAN: hash = janet_unwrap_boolean(x); break; case JANET_STRING: case JANET_SYMBOL: case JANET_KEYWORD: hash = janet_string_hash(janet_unwrap_string(x)); break; case JANET_TUPLE: hash = janet_tuple_hash(janet_unwrap_tuple(x)); uint32_t inc = (janet_tuple_flag(janet_unwrap_tuple(x)) & JANET_TUPLE_FLAG_BRACKETCTOR) ? 1 : 0; hash = (int32_t)((uint32_t)hash + inc); /* avoid overflow undefined behavior */ break; case JANET_STRUCT: hash = janet_struct_hash(janet_unwrap_struct(x)); break; case JANET_NUMBER: { union { double d; uint64_t u; } as; as.d = janet_unwrap_number(x); as.d += 0.0; /* normalize negative 0 */ as.u = murmur64(as.u); uint32_t hi = (uint32_t)(as.u >> 32); hash = (int32_t)hi; break; } case JANET_ABSTRACT: { JanetAbstract xx = janet_unwrap_abstract(x); const JanetAbstractType *at = janet_abstract_type(xx); if (at->hash != NULL) { hash = at->hash(xx, janet_abstract_size(xx)); break; } } /* fallthrough */ default: if (sizeof(double) == sizeof(void *)) { /* Assuming 8 byte pointer (8 byte aligned) */ uint64_t i = murmur64(janet_u64(x)); hash = (int32_t)(i >> 32); } else { /* Assuming 4 byte pointer (or smaller) */ uintptr_t diff = (uintptr_t) janet_unwrap_pointer(x); uint32_t hilo = (uint32_t) diff * 2654435769u; hash = (int32_t)((hilo << 16) | (hilo >> 16)); } break; } return hash; } /* Compares x to y. If they are equal returns 0. If x is less, returns -1. * If y is less, returns 1. All types are comparable * and should have strict ordering, excepts NaNs. */ int janet_compare(Janet x, Janet y) { janet_vm.traversal = janet_vm.traversal_base; int status; do { JanetType tx = janet_type(x); JanetType ty = janet_type(y); if (tx != ty) return tx < ty ? -1 : 1; switch (tx) { case JANET_NIL: break; case JANET_BOOLEAN: { int diff = janet_unwrap_boolean(x) - janet_unwrap_boolean(y); if (diff) return diff; break; } case JANET_NUMBER: { double xx = janet_unwrap_number(x); double yy = janet_unwrap_number(y); if (xx == yy) { break; } else { return (xx < yy) ? -1 : 1; } } case JANET_STRING: case JANET_SYMBOL: case JANET_KEYWORD: { int diff = janet_string_compare(janet_unwrap_string(x), janet_unwrap_string(y)); if (diff) return diff; break; } case JANET_ABSTRACT: { int diff = janet_compare_abstract(janet_unwrap_abstract(x), janet_unwrap_abstract(y)); if (diff) return diff; break; } default: { if (janet_unwrap_pointer(x) == janet_unwrap_pointer(y)) { break; } else { return janet_unwrap_pointer(x) > janet_unwrap_pointer(y) ? 1 : -1; } } case JANET_TUPLE: { const Janet *lhs = janet_unwrap_tuple(x); const Janet *rhs = janet_unwrap_tuple(y); if (JANET_TUPLE_FLAG_BRACKETCTOR & (janet_tuple_flag(lhs) ^ janet_tuple_flag(rhs))) { return (janet_tuple_flag(lhs) & JANET_TUPLE_FLAG_BRACKETCTOR) ? 1 : -1; } push_traversal_node(janet_tuple_head(lhs), janet_tuple_head(rhs), 1); break; } case JANET_STRUCT: { const JanetKV *lhs = janet_unwrap_struct(x); const JanetKV *rhs = janet_unwrap_struct(y); int32_t llen = janet_struct_capacity(lhs); int32_t rlen = janet_struct_capacity(rhs); int32_t lhash = janet_struct_hash(lhs); int32_t rhash = janet_struct_hash(rhs); if (llen < rlen) return -1; if (llen > rlen) return 1; if (lhash < rhash) return -1; if (lhash > rhash) return 1; push_traversal_node(janet_struct_head(lhs), janet_struct_head(rhs), 0); break; } } } while (!(status = traversal_next(&x, &y))); return status - 2; } static int32_t getter_checkint(JanetType type, Janet key, int32_t max) { if (!janet_checkint(key)) goto bad; int32_t ret = janet_unwrap_integer(key); if (ret < 0) goto bad; if (ret >= max) goto bad; return ret; bad: janet_panicf("expected integer key for %s in range [0, %d), got %v", janet_type_names[type], max, key); } /* Gets a value and returns. Can panic. */ Janet janet_in(Janet ds, Janet key) { Janet value; JanetType type = janet_type(ds); switch (type) { default: janet_panicf("expected %T, got %v", JANET_TFLAG_LENGTHABLE, ds); break; case JANET_STRUCT: value = janet_struct_get(janet_unwrap_struct(ds), key); break; case JANET_TABLE: value = janet_table_get(janet_unwrap_table(ds), key); break; case JANET_ARRAY: { JanetArray *array = janet_unwrap_array(ds); int32_t index = getter_checkint(type, key, array->count); value = array->data[index]; break; } case JANET_TUPLE: { const Janet *tuple = janet_unwrap_tuple(ds); int32_t len = janet_tuple_length(tuple); value = tuple[getter_checkint(type, key, len)]; break; } case JANET_BUFFER: { JanetBuffer *buffer = janet_unwrap_buffer(ds); int32_t index = getter_checkint(type, key, buffer->count); value = janet_wrap_integer(buffer->data[index]); break; } case JANET_STRING: case JANET_SYMBOL: case JANET_KEYWORD: { const uint8_t *str = janet_unwrap_string(ds); int32_t index = getter_checkint(type, key, janet_string_length(str)); value = janet_wrap_integer(str[index]); break; } case JANET_ABSTRACT: { JanetAbstractType *type = (JanetAbstractType *)janet_abstract_type(janet_unwrap_abstract(ds)); if (type->get) { if (!(type->get)(janet_unwrap_abstract(ds), key, &value)) janet_panicf("key %v not found in %v ", key, ds); } else { janet_panicf("no getter for %v", ds); } break; } case JANET_FIBER: { /* Bit of a hack to allow iterating over fibers. */ if (janet_equals(key, janet_wrap_integer(0))) { return janet_unwrap_fiber(ds)->last_value; } else { janet_panicf("expected key 0, got %v", key); } } } return value; } Janet janet_get(Janet ds, Janet key) { JanetType t = janet_type(ds); switch (t) { default: return janet_wrap_nil(); case JANET_STRING: case JANET_SYMBOL: case JANET_KEYWORD: { if (!janet_checkint(key)) return janet_wrap_nil(); int32_t index = janet_unwrap_integer(key); if (index < 0) return janet_wrap_nil(); const uint8_t *str = janet_unwrap_string(ds); if (index >= janet_string_length(str)) return janet_wrap_nil(); return janet_wrap_integer(str[index]); } case JANET_ABSTRACT: { Janet value; void *abst = janet_unwrap_abstract(ds); JanetAbstractType *type = (JanetAbstractType *)janet_abstract_type(abst); if (!type->get) return janet_wrap_nil(); if ((type->get)(abst, key, &value)) return value; return janet_wrap_nil(); } case JANET_ARRAY: case JANET_TUPLE: case JANET_BUFFER: { if (!janet_checkint(key)) return janet_wrap_nil(); int32_t index = janet_unwrap_integer(key); if (index < 0) return janet_wrap_nil(); if (t == JANET_ARRAY) { JanetArray *a = janet_unwrap_array(ds); if (index >= a->count) return janet_wrap_nil(); return a->data[index]; } else if (t == JANET_BUFFER) { JanetBuffer *b = janet_unwrap_buffer(ds); if (index >= b->count) return janet_wrap_nil(); return janet_wrap_integer(b->data[index]); } else { const Janet *t = janet_unwrap_tuple(ds); if (index >= janet_tuple_length(t)) return janet_wrap_nil(); return t[index]; } } case JANET_TABLE: { return janet_table_get(janet_unwrap_table(ds), key); } case JANET_STRUCT: { const JanetKV *st = janet_unwrap_struct(ds); return janet_struct_get(st, key); } case JANET_FIBER: { /* Bit of a hack to allow iterating over fibers. */ if (janet_equals(key, janet_wrap_integer(0))) { return janet_unwrap_fiber(ds)->last_value; } else { return janet_wrap_nil(); } } } } Janet janet_getindex(Janet ds, int32_t index) { Janet value; if (index < 0) janet_panic("expected non-negative index"); switch (janet_type(ds)) { default: janet_panicf("expected %T, got %v", JANET_TFLAG_LENGTHABLE, ds); break; case JANET_STRING: case JANET_SYMBOL: case JANET_KEYWORD: if (index >= janet_string_length(janet_unwrap_string(ds))) { value = janet_wrap_nil(); } else { value = janet_wrap_integer(janet_unwrap_string(ds)[index]); } break; case JANET_ARRAY: if (index >= janet_unwrap_array(ds)->count) { value = janet_wrap_nil(); } else { value = janet_unwrap_array(ds)->data[index]; } break; case JANET_BUFFER: if (index >= janet_unwrap_buffer(ds)->count) { value = janet_wrap_nil(); } else { value = janet_wrap_integer(janet_unwrap_buffer(ds)->data[index]); } break; case JANET_TUPLE: if (index >= janet_tuple_length(janet_unwrap_tuple(ds))) { value = janet_wrap_nil(); } else { value = janet_unwrap_tuple(ds)[index]; } break; case JANET_TABLE: value = janet_table_get(janet_unwrap_table(ds), janet_wrap_integer(index)); break; case JANET_STRUCT: value = janet_struct_get(janet_unwrap_struct(ds), janet_wrap_integer(index)); break; case JANET_ABSTRACT: { JanetAbstractType *type = (JanetAbstractType *)janet_abstract_type(janet_unwrap_abstract(ds)); if (type->get) { if (!(type->get)(janet_unwrap_abstract(ds), janet_wrap_integer(index), &value)) value = janet_wrap_nil(); } else { janet_panicf("no getter for %v", ds); } break; } case JANET_FIBER: { if (index == 0) { value = janet_unwrap_fiber(ds)->last_value; } else { value = janet_wrap_nil(); } break; } } return value; } int32_t janet_length(Janet x) { switch (janet_type(x)) { default: janet_panicf("expected %T, got %v", JANET_TFLAG_LENGTHABLE, x); case JANET_STRING: case JANET_SYMBOL: case JANET_KEYWORD: return janet_string_length(janet_unwrap_string(x)); case JANET_ARRAY: return janet_unwrap_array(x)->count; case JANET_BUFFER: return janet_unwrap_buffer(x)->count; case JANET_TUPLE: return janet_tuple_length(janet_unwrap_tuple(x)); case JANET_STRUCT: return janet_struct_length(janet_unwrap_struct(x)); case JANET_TABLE: return janet_unwrap_table(x)->count; case JANET_ABSTRACT: { void *abst = janet_unwrap_abstract(x); const JanetAbstractType *type = janet_abstract_type(abst); if (type->length != NULL) { size_t len = type->length(abst, janet_abstract_size(abst)); if (len > INT32_MAX) { janet_panicf("invalid integer length %u", len); } return (int32_t)(len); } Janet argv[1] = { x }; Janet len = janet_mcall("length", 1, argv); if (!janet_checkint(len)) janet_panicf("invalid integer length %v", len); return janet_unwrap_integer(len); } } } Janet janet_lengthv(Janet x) { switch (janet_type(x)) { default: janet_panicf("expected %T, got %v", JANET_TFLAG_LENGTHABLE, x); case JANET_STRING: case JANET_SYMBOL: case JANET_KEYWORD: return janet_wrap_integer(janet_string_length(janet_unwrap_string(x))); case JANET_ARRAY: return janet_wrap_integer(janet_unwrap_array(x)->count); case JANET_BUFFER: return janet_wrap_integer(janet_unwrap_buffer(x)->count); case JANET_TUPLE: return janet_wrap_integer(janet_tuple_length(janet_unwrap_tuple(x))); case JANET_STRUCT: return janet_wrap_integer(janet_struct_length(janet_unwrap_struct(x))); case JANET_TABLE: return janet_wrap_integer(janet_unwrap_table(x)->count); case JANET_ABSTRACT: { void *abst = janet_unwrap_abstract(x); const JanetAbstractType *type = janet_abstract_type(abst); if (type->length != NULL) { size_t len = type->length(abst, janet_abstract_size(abst)); /* If len is always less then double, we can never overflow */ #ifdef JANET_32 return janet_wrap_number(len); #else if (len < (size_t) JANET_INTMAX_INT64) { return janet_wrap_number((double) len); } else { janet_panicf("integer length %u too large", len); } #endif } Janet argv[1] = { x }; return janet_mcall("length", 1, argv); } } } void janet_putindex(Janet ds, int32_t index, Janet value) { switch (janet_type(ds)) { default: janet_panicf("expected %T, got %v", JANET_TFLAG_ARRAY | JANET_TFLAG_BUFFER | JANET_TFLAG_TABLE, ds); case JANET_ARRAY: { JanetArray *array = janet_unwrap_array(ds); if (index >= array->count) { janet_array_ensure(array, index + 1, 2); for (int32_t i = array->count; i < index + 1; i++) { array->data[i] = janet_wrap_nil(); } array->count = index + 1; } array->data[index] = value; break; } case JANET_BUFFER: { JanetBuffer *buffer = janet_unwrap_buffer(ds); if (!janet_checkint(value)) janet_panicf("can only put integers in buffers, got %v", value); if (index >= buffer->count) { janet_buffer_ensure(buffer, index + 1, 2); memset(buffer->data + buffer->count, 0, index + 1 - buffer->count); buffer->count = index + 1; } buffer->data[index] = (uint8_t)(janet_unwrap_integer(value) & 0xFF); break; } case JANET_TABLE: { JanetTable *table = janet_unwrap_table(ds); janet_table_put(table, janet_wrap_integer(index), value); break; } case JANET_ABSTRACT: { JanetAbstractType *type = (JanetAbstractType *)janet_abstract_type(janet_unwrap_abstract(ds)); if (type->put) { (type->put)(janet_unwrap_abstract(ds), janet_wrap_integer(index), value); } else { janet_panicf("no setter for %v ", ds); } break; } } } void janet_put(Janet ds, Janet key, Janet value) { JanetType type = janet_type(ds); switch (type) { default: janet_panicf("expected %T, got %v", JANET_TFLAG_ARRAY | JANET_TFLAG_BUFFER | JANET_TFLAG_TABLE, ds); case JANET_ARRAY: { JanetArray *array = janet_unwrap_array(ds); int32_t index = getter_checkint(type, key, INT32_MAX - 1); if (index >= array->count) { janet_array_ensure(array, index + 1, 2); for (int32_t i = array->count; i < index + 1; i++) { array->data[i] = janet_wrap_nil(); } array->count = index + 1; } array->data[index] = value; break; } case JANET_BUFFER: { JanetBuffer *buffer = janet_unwrap_buffer(ds); int32_t index = getter_checkint(type, key, INT32_MAX - 1); if (!janet_checkint(value)) janet_panicf("can only put integers in buffers, got %v", value); if (index >= buffer->count) { janet_buffer_ensure(buffer, index + 1, 2); memset(buffer->data + buffer->count, 0, index + 1 - buffer->count); buffer->count = index + 1; } buffer->data[index] = (uint8_t)(janet_unwrap_integer(value) & 0xFF); break; } case JANET_TABLE: janet_table_put(janet_unwrap_table(ds), key, value); break; case JANET_ABSTRACT: { JanetAbstractType *type = (JanetAbstractType *)janet_abstract_type(janet_unwrap_abstract(ds)); if (type->put) { (type->put)(janet_unwrap_abstract(ds), key, value); } else { janet_panicf("no setter for %v ", ds); } break; } } } janet-1.41.2/src/core/vector.c000066400000000000000000000040231514534607600160770ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include "vector.h" #include "util.h" #endif /* Grow the buffer dynamically. Used for push operations. */ void *janet_v_grow(void *v, int32_t increment, int32_t itemsize) { int32_t dbl_cur = (NULL != v) ? 2 * janet_v__cap(v) : 0; int32_t min_needed = janet_v_count(v) + increment; int32_t m = dbl_cur > min_needed ? dbl_cur : min_needed; size_t newsize = ((size_t) itemsize) * m + sizeof(int32_t) * 2; int32_t *p = (int32_t *) janet_srealloc(v ? janet_v__raw(v) : 0, newsize); if (!v) p[1] = 0; p[0] = m; return p + 2; } /* Convert a buffer to normal allocated memory (forget capacity) */ void *janet_v_flattenmem(void *v, int32_t itemsize) { char *p; if (NULL == v) return NULL; size_t size = (size_t) itemsize * janet_v__cnt(v); p = janet_malloc(size); if (NULL != p) { safe_memcpy(p, v, size); return p; } else { JANET_OUT_OF_MEMORY; } } janet-1.41.2/src/core/vector.h000066400000000000000000000051001514534607600161010ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_VECTOR_H_defined #define JANET_VECTOR_H_defined #ifndef JANET_AMALG #include "features.h" #include #endif /* * vector code modified from * https://github.com/nothings/stb/blob/master/stretchy_buffer.h */ /* This is mainly used code such as the assembler or compiler, which * need vector like data structures that are only garbage collected in case * of an error, and normally rely on malloc/free. */ #define janet_v_free(v) (((v) != NULL) ? (janet_sfree(janet_v__raw(v)), 0) : 0) #define janet_v_push(v, x) (janet_v__maybegrow(v, 1), (v)[janet_v__cnt(v)++] = (x)) #define janet_v_pop(v) (janet_v_count(v) ? janet_v__cnt(v)-- : 0) #define janet_v_count(v) (((v) != NULL) ? janet_v__cnt(v) : 0) #define janet_v_last(v) ((v)[janet_v__cnt(v) - 1]) #define janet_v_empty(v) (((v) != NULL) ? (janet_v__cnt(v) = 0) : 0) #define janet_v_flatten(v) (janet_v_flattenmem((v), sizeof(*(v)))) #define janet_v__raw(v) ((int32_t *)(v) - 2) #define janet_v__cap(v) janet_v__raw(v)[0] #define janet_v__cnt(v) janet_v__raw(v)[1] #define janet_v__needgrow(v, n) ((v) == NULL || janet_v__cnt(v) + (n) >= janet_v__cap(v)) #define janet_v__maybegrow(v, n) (janet_v__needgrow((v), (n)) ? janet_v__grow((v), (n)) : 0) #define janet_v__grow(v, n) ((v) = janet_v_grow((v), (n), sizeof(*(v)))) /* Actual functions defined in vector.c */ void *janet_v_grow(void *v, int32_t increment, int32_t itemsize); void *janet_v_flattenmem(void *v, int32_t itemsize); #endif janet-1.41.2/src/core/vm.c000066400000000000000000001555131514534607600152320ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include "state.h" #include "fiber.h" #include "gc.h" #include "symcache.h" #include "util.h" #endif #include /* Virtual registers * * One instruction word * CC | BB | AA | OP * DD | DD | DD | OP * EE | EE | AA | OP */ #define A ((*pc >> 8) & 0xFF) #define B ((*pc >> 16) & 0xFF) #define C (*pc >> 24) #define D (*pc >> 8) #define E (*pc >> 16) /* Signed interpretations of registers */ #define CS (*((int32_t *)pc) >> 24) #define DS (*((int32_t *)pc) >> 8) #define ES (*((int32_t *)pc) >> 16) /* How we dispatch instructions. By default, we use * a switch inside an infinite loop. For GCC/clang, we use * computed gotos. */ #if defined(__GNUC__) && !defined(__EMSCRIPTEN__) #define JANET_USE_COMPUTED_GOTOS #endif #ifdef JANET_USE_COMPUTED_GOTOS #define VM_START() { goto *op_lookup[first_opcode]; #define VM_END() } #define VM_OP(op) label_##op : #define VM_DEFAULT() label_unknown_op: #define vm_next() goto *op_lookup[*pc & 0xFF] #define opcode (*pc & 0xFF) #else #define VM_START() uint8_t opcode = first_opcode; for (;;) {switch(opcode) { #define VM_END() }} #define VM_OP(op) case op : #define VM_DEFAULT() default: #define vm_next() opcode = *pc & 0xFF; continue #endif /* Commit and restore VM state before possible longjmp */ #define vm_commit() do { janet_stack_frame(stack)->pc = pc; } while (0) #define vm_restore() do { \ stack = fiber->data + fiber->frame; \ pc = janet_stack_frame(stack)->pc; \ func = janet_stack_frame(stack)->func; \ } while (0) #define vm_return(sig, val) do { \ janet_vm.return_reg[0] = (val); \ vm_commit(); \ return (sig); \ } while (0) #define vm_return_no_restore(sig, val) do { \ janet_vm.return_reg[0] = (val); \ return (sig); \ } while (0) /* Next instruction variations */ #define maybe_collect() do {\ if (janet_vm.next_collection >= janet_vm.gc_interval) janet_collect(); } while (0) #define vm_checkgc_next() maybe_collect(); vm_next() #define vm_pcnext() pc++; vm_next() #define vm_checkgc_pcnext() maybe_collect(); vm_pcnext() /* Handle certain errors in main vm loop */ #define vm_throw(e) do { vm_commit(); janet_panic(e); } while (0) #define vm_assert(cond, e) do {if (!(cond)) vm_throw((e)); } while (0) #define vm_assert_type(X, T) do { \ if (!(janet_checktype((X), (T)))) { \ vm_commit(); \ janet_panicf("expected %T, got %v", (1 << (T)), (X)); \ } \ } while (0) #define vm_assert_types(X, TS) do { \ if (!(janet_checktypes((X), (TS)))) { \ vm_commit(); \ janet_panicf("expected %T, got %v", (TS), (X)); \ } \ } while (0) #ifdef JANET_NO_INTERPRETER_INTERRUPT #define vm_maybe_auto_suspend(COND) #else #define vm_maybe_auto_suspend(COND) do { \ if ((COND) && janet_atomic_load_relaxed(&janet_vm.auto_suspend)) { \ fiber->flags |= (JANET_FIBER_RESUME_NO_USEVAL | JANET_FIBER_RESUME_NO_SKIP); \ vm_return(JANET_SIGNAL_INTERRUPT, janet_wrap_nil()); \ } \ } while (0) #endif /* Templates for certain patterns in opcodes */ #define vm_binop_immediate(op)\ {\ Janet op1 = stack[B];\ if (!janet_checktype(op1, JANET_NUMBER)) {\ vm_commit();\ Janet _argv[2] = { op1, janet_wrap_number(CS) };\ Janet a = janet_mcall(#op, 2, _argv);\ stack = fiber->data + fiber->frame;\ stack[A] = a;\ vm_checkgc_pcnext();\ } else {\ double x1 = janet_unwrap_number(op1);\ stack[A] = janet_wrap_number(x1 op CS);\ vm_pcnext();\ }\ } #define _vm_bitop_immediate(op, type1, rangecheck, msg)\ {\ Janet op1 = stack[B];\ if (!janet_checktype(op1, JANET_NUMBER)) {\ vm_commit();\ Janet _argv[2] = { op1, janet_wrap_number(CS) };\ Janet a = janet_mcall(#op, 2, _argv);\ stack = fiber->data + fiber->frame;\ stack[A] = a;\ vm_checkgc_pcnext();\ } else {\ double y1 = janet_unwrap_number(op1);\ if (!rangecheck(y1)) { vm_commit(); janet_panicf("value %v out of range for " msg, op1); }\ type1 x1 = (type1) y1;\ stack[A] = janet_wrap_number((type1) (x1 op CS));\ vm_pcnext();\ }\ } #define vm_bitop_immediate(op) _vm_bitop_immediate(op, int32_t, janet_checkintrange, "32-bit signed integers"); #define vm_bitopu_immediate(op) _vm_bitop_immediate(op, uint32_t, janet_checkuintrange, "32-bit unsigned integers"); #define _vm_binop(op, wrap)\ {\ Janet op1 = stack[B];\ Janet op2 = stack[C];\ if (janet_checktype(op1, JANET_NUMBER) && janet_checktype(op2, JANET_NUMBER)) {\ double x1 = janet_unwrap_number(op1);\ double x2 = janet_unwrap_number(op2);\ stack[A] = wrap(x1 op x2);\ vm_pcnext();\ } else {\ vm_commit();\ Janet a = janet_binop_call(#op, "r" #op, op1, op2);\ stack = fiber->data + fiber->frame;\ stack[A] = a;\ vm_checkgc_pcnext();\ }\ } #define vm_binop(op) _vm_binop(op, janet_wrap_number) #define _vm_bitop(op, type1, rangecheck, msg)\ {\ Janet op1 = stack[B];\ Janet op2 = stack[C];\ if (janet_checktype(op1, JANET_NUMBER) && janet_checktype(op2, JANET_NUMBER)) {\ double y1 = janet_unwrap_number(op1);\ double y2 = janet_unwrap_number(op2);\ if (!rangecheck(y1)) { vm_commit(); janet_panicf("value %v out of range for " msg, op1); }\ if (!janet_checkintrange(y2)) { vm_commit(); janet_panicf("rhs must be valid 32-bit signed integer, got %f", op2); }\ type1 x1 = (type1) y1;\ int32_t x2 = (int32_t) y2;\ stack[A] = janet_wrap_number((type1) (x1 op x2));\ vm_pcnext();\ } else {\ vm_commit();\ Janet a = janet_binop_call(#op, "r" #op, op1, op2);\ stack = fiber->data + fiber->frame;\ stack[A] = a;\ vm_checkgc_pcnext();\ }\ } #define vm_bitop(op) _vm_bitop(op, int32_t, janet_checkintrange, "32-bit signed integers") #define vm_bitopu(op) _vm_bitop(op, uint32_t, janet_checkuintrange, "32-bit unsigned integers") #define vm_compop(op) \ {\ Janet op1 = stack[B];\ Janet op2 = stack[C];\ if (janet_checktype(op1, JANET_NUMBER) && janet_checktype(op2, JANET_NUMBER)) {\ double x1 = janet_unwrap_number(op1);\ double x2 = janet_unwrap_number(op2);\ stack[A] = janet_wrap_boolean(x1 op x2);\ vm_pcnext();\ } else {\ vm_commit();\ Janet a = janet_wrap_boolean(janet_compare(op1, op2) op 0);\ stack = fiber->data + fiber->frame;\ stack[A] = a;\ vm_checkgc_pcnext();\ }\ } #define vm_compop_imm(op) \ {\ Janet op1 = stack[B];\ if (janet_checktype(op1, JANET_NUMBER)) {\ double x1 = janet_unwrap_number(op1);\ double x2 = (double) CS; \ stack[A] = janet_wrap_boolean(x1 op x2);\ vm_pcnext();\ } else {\ vm_commit();\ Janet a = janet_wrap_boolean(janet_compare(op1, janet_wrap_integer(CS)) op 0);\ stack = fiber->data + fiber->frame;\ stack[A] = a;\ vm_checkgc_pcnext();\ }\ } /* Trace a function call */ static void vm_do_trace(JanetFunction *func, int32_t argc, const Janet *argv) { if (func->def->name) { janet_eprintf("trace (%S", func->def->name); } else { janet_eprintf("trace (%p", janet_wrap_function(func)); } for (int32_t i = 0; i < argc; i++) { janet_eprintf(" %p", argv[i]); } janet_eprintf(")\n"); } /* Invoke a method once we have looked it up */ static Janet janet_method_invoke(Janet method, int32_t argc, Janet *argv) { switch (janet_type(method)) { case JANET_CFUNCTION: return (janet_unwrap_cfunction(method))(argc, argv); case JANET_FUNCTION: { JanetFunction *fun = janet_unwrap_function(method); return janet_call(fun, argc, argv); } case JANET_ABSTRACT: { JanetAbstract abst = janet_unwrap_abstract(method); const JanetAbstractType *at = janet_abstract_type(abst); if (NULL != at->call) { return at->call(abst, argc, argv); } } /* fallthrough */ case JANET_STRING: case JANET_BUFFER: case JANET_TABLE: case JANET_STRUCT: case JANET_ARRAY: case JANET_TUPLE: { if (argc != 1) { janet_panicf("%v called with %d arguments, possibly expected 1", method, argc); } return janet_in(method, argv[0]); } default: { if (argc != 1) { janet_panicf("%v called with %d arguments, possibly expected 1", method, argc); } return janet_in(argv[0], method); } } } /* Call a non function type from a JOP_CALL or JOP_TAILCALL instruction. * Assumes that the arguments are on the fiber stack. */ static Janet call_nonfn(JanetFiber *fiber, Janet callee) { int32_t argc = fiber->stacktop - fiber->stackstart; fiber->stacktop = fiber->stackstart; return janet_method_invoke(callee, argc, fiber->data + fiber->stacktop); } /* Method lookup could potentially handle tables specially... */ static Janet method_to_fun(Janet method, Janet obj) { return janet_get(obj, method); } /* Get a callable from a keyword method name and ensure that it is valid. */ static Janet resolve_method(Janet name, JanetFiber *fiber) { int32_t argc = fiber->stacktop - fiber->stackstart; if (argc < 1) janet_panicf("method call (%v) takes at least 1 argument, got 0", name); Janet callee = method_to_fun(name, fiber->data[fiber->stackstart]); if (janet_checktype(callee, JANET_NIL)) janet_panicf("unknown method %v invoked on %v", name, fiber->data[fiber->stackstart]); return callee; } /* Lookup method on value x */ static Janet janet_method_lookup(Janet x, const char *name) { return method_to_fun(janet_ckeywordv(name), x); } static Janet janet_unary_call(const char *method, Janet arg) { Janet m = janet_method_lookup(arg, method); if (janet_checktype(m, JANET_NIL)) { janet_panicf("could not find method :%s for %v", method, arg); } else { Janet argv[1] = { arg }; return janet_method_invoke(m, 1, argv); } } /* Call a method first on the righthand side, and then on the left hand side with a prefix */ static Janet janet_binop_call(const char *lmethod, const char *rmethod, Janet lhs, Janet rhs) { Janet lm = janet_method_lookup(lhs, lmethod); if (janet_checktype(lm, JANET_NIL)) { /* Invert order for rmethod */ Janet lr = janet_method_lookup(rhs, rmethod); Janet argv[2] = { rhs, lhs }; if (janet_checktype(lr, JANET_NIL)) { janet_panicf("could not find method :%s for %v or :%s for %v", lmethod, lhs, rmethod, rhs); } return janet_method_invoke(lr, 2, argv); } else { Janet argv[2] = { lhs, rhs }; return janet_method_invoke(lm, 2, argv); } } /* Forward declaration */ static JanetSignal janet_check_can_resume(JanetFiber *fiber, Janet *out, int is_cancel); static JanetSignal janet_continue_no_check(JanetFiber *fiber, Janet in, Janet *out); /* Interpreter main loop */ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { /* opcode -> label lookup if using clang/GCC */ #ifdef JANET_USE_COMPUTED_GOTOS static void *op_lookup[255] = { &&label_JOP_NOOP, &&label_JOP_ERROR, &&label_JOP_TYPECHECK, &&label_JOP_RETURN, &&label_JOP_RETURN_NIL, &&label_JOP_ADD_IMMEDIATE, &&label_JOP_ADD, &&label_JOP_SUBTRACT_IMMEDIATE, &&label_JOP_SUBTRACT, &&label_JOP_MULTIPLY_IMMEDIATE, &&label_JOP_MULTIPLY, &&label_JOP_DIVIDE_IMMEDIATE, &&label_JOP_DIVIDE, &&label_JOP_DIVIDE_FLOOR, &&label_JOP_MODULO, &&label_JOP_REMAINDER, &&label_JOP_BAND, &&label_JOP_BOR, &&label_JOP_BXOR, &&label_JOP_BNOT, &&label_JOP_SHIFT_LEFT, &&label_JOP_SHIFT_LEFT_IMMEDIATE, &&label_JOP_SHIFT_RIGHT, &&label_JOP_SHIFT_RIGHT_IMMEDIATE, &&label_JOP_SHIFT_RIGHT_UNSIGNED, &&label_JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE, &&label_JOP_MOVE_FAR, &&label_JOP_MOVE_NEAR, &&label_JOP_JUMP, &&label_JOP_JUMP_IF, &&label_JOP_JUMP_IF_NOT, &&label_JOP_JUMP_IF_NIL, &&label_JOP_JUMP_IF_NOT_NIL, &&label_JOP_GREATER_THAN, &&label_JOP_GREATER_THAN_IMMEDIATE, &&label_JOP_LESS_THAN, &&label_JOP_LESS_THAN_IMMEDIATE, &&label_JOP_EQUALS, &&label_JOP_EQUALS_IMMEDIATE, &&label_JOP_COMPARE, &&label_JOP_LOAD_NIL, &&label_JOP_LOAD_TRUE, &&label_JOP_LOAD_FALSE, &&label_JOP_LOAD_INTEGER, &&label_JOP_LOAD_CONSTANT, &&label_JOP_LOAD_UPVALUE, &&label_JOP_LOAD_SELF, &&label_JOP_SET_UPVALUE, &&label_JOP_CLOSURE, &&label_JOP_PUSH, &&label_JOP_PUSH_2, &&label_JOP_PUSH_3, &&label_JOP_PUSH_ARRAY, &&label_JOP_CALL, &&label_JOP_TAILCALL, &&label_JOP_RESUME, &&label_JOP_SIGNAL, &&label_JOP_PROPAGATE, &&label_JOP_IN, &&label_JOP_GET, &&label_JOP_PUT, &&label_JOP_GET_INDEX, &&label_JOP_PUT_INDEX, &&label_JOP_LENGTH, &&label_JOP_MAKE_ARRAY, &&label_JOP_MAKE_BUFFER, &&label_JOP_MAKE_STRING, &&label_JOP_MAKE_STRUCT, &&label_JOP_MAKE_TABLE, &&label_JOP_MAKE_TUPLE, &&label_JOP_MAKE_BRACKET_TUPLE, &&label_JOP_GREATER_THAN_EQUAL, &&label_JOP_LESS_THAN_EQUAL, &&label_JOP_NEXT, &&label_JOP_NOT_EQUALS, &&label_JOP_NOT_EQUALS_IMMEDIATE, &&label_JOP_CANCEL, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op, &&label_unknown_op }; #endif /* Interpreter state */ register Janet *stack; register uint32_t *pc; register JanetFunction *func; if (fiber->flags & JANET_FIBER_RESUME_SIGNAL) { JanetSignal sig = (fiber->gc.flags & JANET_FIBER_STATUS_MASK) >> JANET_FIBER_STATUS_OFFSET; fiber->gc.flags &= ~JANET_FIBER_STATUS_MASK; fiber->flags &= ~(JANET_FIBER_RESUME_SIGNAL | JANET_FIBER_FLAG_MASK); janet_vm.return_reg[0] = in; return sig; } vm_restore(); if (fiber->flags & JANET_FIBER_DID_LONGJUMP) { if (janet_fiber_frame(fiber)->func == NULL) { /* Inside a c function */ janet_fiber_popframe(fiber); vm_restore(); } /* Check if we were at a tail call instruction. If so, do implicit return */ if ((*pc & 0xFF) == JOP_TAILCALL) { /* Tail call resume */ int entrance_frame = janet_stack_frame(stack)->flags & JANET_STACKFRAME_ENTRANCE; janet_fiber_popframe(fiber); if (entrance_frame) { fiber->flags &= ~JANET_FIBER_FLAG_MASK; vm_return(JANET_SIGNAL_OK, in); } vm_restore(); } } if (!(fiber->flags & JANET_FIBER_RESUME_NO_USEVAL)) stack[A] = in; if (!(fiber->flags & JANET_FIBER_RESUME_NO_SKIP)) pc++; uint8_t first_opcode = *pc & ((fiber->flags & JANET_FIBER_BREAKPOINT) ? 0x7F : 0xFF); fiber->flags &= ~JANET_FIBER_FLAG_MASK; /* Main interpreter loop. Semantically is a switch on * (*pc & 0xFF) inside of an infinite loop. */ VM_START(); VM_DEFAULT(); fiber->flags |= JANET_FIBER_BREAKPOINT | JANET_FIBER_RESUME_NO_USEVAL | JANET_FIBER_RESUME_NO_SKIP; vm_return(JANET_SIGNAL_DEBUG, janet_wrap_nil()); VM_OP(JOP_NOOP) vm_pcnext(); VM_OP(JOP_ERROR) vm_return(JANET_SIGNAL_ERROR, stack[A]); VM_OP(JOP_TYPECHECK) vm_assert_types(stack[A], E); vm_pcnext(); VM_OP(JOP_RETURN) { Janet retval = stack[D]; int entrance_frame = janet_stack_frame(stack)->flags & JANET_STACKFRAME_ENTRANCE; janet_fiber_popframe(fiber); if (entrance_frame) vm_return_no_restore(JANET_SIGNAL_OK, retval); vm_restore(); stack[A] = retval; vm_checkgc_pcnext(); } VM_OP(JOP_RETURN_NIL) { Janet retval = janet_wrap_nil(); int entrance_frame = janet_stack_frame(stack)->flags & JANET_STACKFRAME_ENTRANCE; janet_fiber_popframe(fiber); if (entrance_frame) vm_return_no_restore(JANET_SIGNAL_OK, retval); vm_restore(); stack[A] = retval; vm_checkgc_pcnext(); } VM_OP(JOP_ADD_IMMEDIATE) vm_binop_immediate(+); VM_OP(JOP_ADD) vm_binop(+); VM_OP(JOP_SUBTRACT_IMMEDIATE) vm_binop_immediate(-); VM_OP(JOP_SUBTRACT) vm_binop(-); VM_OP(JOP_MULTIPLY_IMMEDIATE) vm_binop_immediate(*); VM_OP(JOP_MULTIPLY) vm_binop(*); VM_OP(JOP_DIVIDE_IMMEDIATE) vm_binop_immediate( /); VM_OP(JOP_DIVIDE) vm_binop( /); VM_OP(JOP_DIVIDE_FLOOR) { Janet op1 = stack[B]; Janet op2 = stack[C]; if (janet_checktype(op1, JANET_NUMBER) && janet_checktype(op2, JANET_NUMBER)) { double x1 = janet_unwrap_number(op1); double x2 = janet_unwrap_number(op2); stack[A] = janet_wrap_number(floor(x1 / x2)); vm_pcnext(); } else { vm_commit(); Janet a = janet_binop_call("div", "rdiv", op1, op2); stack = fiber->data + fiber->frame; stack[A] = a; vm_checkgc_pcnext(); } } VM_OP(JOP_MODULO) { Janet op1 = stack[B]; Janet op2 = stack[C]; if (janet_checktype(op1, JANET_NUMBER) && janet_checktype(op2, JANET_NUMBER)) { double x1 = janet_unwrap_number(op1); double x2 = janet_unwrap_number(op2); if (x2 == 0) { stack[A] = janet_wrap_number(x1); } else { double intres = x2 * floor(x1 / x2); stack[A] = janet_wrap_number(x1 - intres); } vm_pcnext(); } else { vm_commit(); Janet a = janet_binop_call("mod", "rmod", op1, op2); stack = fiber->data + fiber->frame; stack[A] = a; vm_checkgc_pcnext(); } } VM_OP(JOP_REMAINDER) { Janet op1 = stack[B]; Janet op2 = stack[C]; if (janet_checktype(op1, JANET_NUMBER) && janet_checktype(op2, JANET_NUMBER)) { double x1 = janet_unwrap_number(op1); double x2 = janet_unwrap_number(op2); stack[A] = janet_wrap_number(fmod(x1, x2)); vm_pcnext(); } else { vm_commit(); Janet a = janet_binop_call("%", "r%", op1, op2); stack = fiber->data + fiber->frame; stack[A] = a; vm_checkgc_pcnext(); } } VM_OP(JOP_BAND) vm_bitop(&); VM_OP(JOP_BOR) vm_bitop( |); VM_OP(JOP_BXOR) vm_bitop(^); VM_OP(JOP_BNOT) { Janet op = stack[E]; if (janet_checktype(op, JANET_NUMBER)) { stack[A] = janet_wrap_integer(~janet_unwrap_integer(op)); vm_pcnext(); } else { vm_commit(); Janet a = janet_unary_call("~", op); stack = fiber->data + fiber->frame; stack[A] = a; vm_checkgc_pcnext(); } } VM_OP(JOP_SHIFT_RIGHT_UNSIGNED) vm_bitopu( >>); VM_OP(JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE) vm_bitopu_immediate( >>); VM_OP(JOP_SHIFT_RIGHT) vm_bitop( >>); VM_OP(JOP_SHIFT_RIGHT_IMMEDIATE) vm_bitop_immediate( >>); VM_OP(JOP_SHIFT_LEFT) vm_bitop( <<); VM_OP(JOP_SHIFT_LEFT_IMMEDIATE) vm_bitop_immediate( <<); VM_OP(JOP_MOVE_NEAR) stack[A] = stack[E]; vm_pcnext(); VM_OP(JOP_MOVE_FAR) stack[E] = stack[A]; vm_pcnext(); VM_OP(JOP_JUMP) vm_maybe_auto_suspend(DS <= 0); pc += DS; vm_next(); VM_OP(JOP_JUMP_IF) if (janet_truthy(stack[A])) { vm_maybe_auto_suspend(ES <= 0); pc += ES; } else { pc++; } vm_next(); VM_OP(JOP_JUMP_IF_NOT) if (janet_truthy(stack[A])) { pc++; } else { vm_maybe_auto_suspend(ES <= 0); pc += ES; } vm_next(); VM_OP(JOP_JUMP_IF_NIL) if (janet_checktype(stack[A], JANET_NIL)) { vm_maybe_auto_suspend(ES <= 0); pc += ES; } else { pc++; } vm_next(); VM_OP(JOP_JUMP_IF_NOT_NIL) if (janet_checktype(stack[A], JANET_NIL)) { pc++; } else { vm_maybe_auto_suspend(ES <= 0); pc += ES; } vm_next(); VM_OP(JOP_LESS_THAN) vm_compop( <); VM_OP(JOP_LESS_THAN_EQUAL) vm_compop( <=); VM_OP(JOP_LESS_THAN_IMMEDIATE) vm_compop_imm( <); VM_OP(JOP_GREATER_THAN) vm_compop( >); VM_OP(JOP_GREATER_THAN_EQUAL) vm_compop( >=); VM_OP(JOP_GREATER_THAN_IMMEDIATE) vm_compop_imm( >); VM_OP(JOP_EQUALS) stack[A] = janet_wrap_boolean(janet_equals(stack[B], stack[C])); vm_pcnext(); VM_OP(JOP_EQUALS_IMMEDIATE) stack[A] = janet_wrap_boolean(janet_checktype(stack[B], JANET_NUMBER) && (janet_unwrap_number(stack[B]) == (double) CS)); vm_pcnext(); VM_OP(JOP_NOT_EQUALS) stack[A] = janet_wrap_boolean(!janet_equals(stack[B], stack[C])); vm_pcnext(); VM_OP(JOP_NOT_EQUALS_IMMEDIATE) stack[A] = janet_wrap_boolean(!janet_checktype(stack[B], JANET_NUMBER) || (janet_unwrap_number(stack[B]) != (double) CS)); vm_pcnext(); VM_OP(JOP_COMPARE) { Janet a = janet_wrap_integer(janet_compare(stack[B], stack[C])); stack = fiber->data + fiber->frame; stack[A] = a; } vm_pcnext(); VM_OP(JOP_NEXT) vm_commit(); { Janet temp = janet_next_impl(stack[B], stack[C], 1); vm_restore(); stack[A] = temp; } vm_pcnext(); VM_OP(JOP_LOAD_NIL) stack[D] = janet_wrap_nil(); vm_pcnext(); VM_OP(JOP_LOAD_TRUE) stack[D] = janet_wrap_true(); vm_pcnext(); VM_OP(JOP_LOAD_FALSE) stack[D] = janet_wrap_false(); vm_pcnext(); VM_OP(JOP_LOAD_INTEGER) stack[A] = janet_wrap_integer(ES); vm_pcnext(); VM_OP(JOP_LOAD_CONSTANT) { int32_t cindex = (int32_t)E; vm_assert(cindex < func->def->constants_length, "invalid constant"); stack[A] = func->def->constants[cindex]; vm_pcnext(); } VM_OP(JOP_LOAD_SELF) stack[D] = janet_wrap_function(func); vm_pcnext(); VM_OP(JOP_LOAD_UPVALUE) { int32_t eindex = B; int32_t vindex = C; JanetFuncEnv *env; vm_assert(func->def->environments_length > eindex, "invalid upvalue environment"); env = func->envs[eindex]; vm_assert(env->length > vindex, "invalid upvalue index"); vm_assert(janet_env_valid(env), "invalid upvalue environment"); if (env->offset > 0) { /* On stack */ stack[A] = env->as.fiber->data[env->offset + vindex]; } else { /* Off stack */ stack[A] = env->as.values[vindex]; } vm_pcnext(); } VM_OP(JOP_SET_UPVALUE) { int32_t eindex = B; int32_t vindex = C; JanetFuncEnv *env; vm_assert(func->def->environments_length > eindex, "invalid upvalue environment"); env = func->envs[eindex]; vm_assert(env->length > vindex, "invalid upvalue index"); vm_assert(janet_env_valid(env), "invalid upvalue environment"); if (env->offset > 0) { env->as.fiber->data[env->offset + vindex] = stack[A]; } else { env->as.values[vindex] = stack[A]; } vm_pcnext(); } VM_OP(JOP_CLOSURE) { JanetFuncDef *fd; JanetFunction *fn; int32_t elen; int32_t defindex = (int32_t)E; vm_assert(defindex < func->def->defs_length, "invalid funcdef"); fd = func->def->defs[defindex]; elen = fd->environments_length; fn = janet_gcalloc(JANET_MEMORY_FUNCTION, sizeof(JanetFunction) + ((size_t) elen * sizeof(JanetFuncEnv *))); fn->def = fd; { int32_t i; for (i = 0; i < elen; ++i) { int32_t inherit = fd->environments[i]; if (inherit == -1 || inherit >= func->def->environments_length) { JanetStackFrame *frame = janet_stack_frame(stack); if (!frame->env) { /* Lazy capture of current stack frame */ JanetFuncEnv *env = janet_gcalloc(JANET_MEMORY_FUNCENV, sizeof(JanetFuncEnv)); env->offset = fiber->frame; env->as.fiber = fiber; env->length = func->def->slotcount; frame->env = env; } fn->envs[i] = frame->env; } else { fn->envs[i] = func->envs[inherit]; } } } stack[A] = janet_wrap_function(fn); vm_checkgc_pcnext(); } VM_OP(JOP_PUSH) janet_fiber_push(fiber, stack[D]); stack = fiber->data + fiber->frame; vm_checkgc_pcnext(); VM_OP(JOP_PUSH_2) janet_fiber_push2(fiber, stack[A], stack[E]); stack = fiber->data + fiber->frame; vm_checkgc_pcnext(); VM_OP(JOP_PUSH_3) janet_fiber_push3(fiber, stack[A], stack[B], stack[C]); stack = fiber->data + fiber->frame; vm_checkgc_pcnext(); VM_OP(JOP_PUSH_ARRAY) { const Janet *vals; int32_t len; if (janet_indexed_view(stack[D], &vals, &len)) { janet_fiber_pushn(fiber, vals, len); } else { janet_panicf("expected %T, got %v", JANET_TFLAG_INDEXED, stack[D]); } } stack = fiber->data + fiber->frame; vm_checkgc_pcnext(); VM_OP(JOP_CALL) { vm_maybe_auto_suspend(1); Janet callee = stack[E]; if (fiber->stacktop > fiber->maxstack) { vm_throw("stack overflow"); } if (janet_checktype(callee, JANET_KEYWORD)) { vm_commit(); callee = resolve_method(callee, fiber); } if (janet_checktype(callee, JANET_FUNCTION)) { func = janet_unwrap_function(callee); if (func->gc.flags & JANET_FUNCFLAG_TRACE) { vm_do_trace(func, fiber->stacktop - fiber->stackstart, fiber->data + fiber->stackstart); } vm_commit(); if (janet_fiber_funcframe(fiber, func)) { int32_t n = fiber->stacktop - fiber->stackstart; janet_panicf("%v called with %d argument%s, expected %d", callee, n, n == 1 ? "" : "s", func->def->arity); } stack = fiber->data + fiber->frame; pc = func->def->bytecode; vm_checkgc_next(); } else if (janet_checktype(callee, JANET_CFUNCTION)) { vm_commit(); int32_t argc = fiber->stacktop - fiber->stackstart; janet_fiber_cframe(fiber, janet_unwrap_cfunction(callee)); Janet ret = janet_unwrap_cfunction(callee)(argc, fiber->data + fiber->frame); janet_fiber_popframe(fiber); stack = fiber->data + fiber->frame; stack[A] = ret; vm_checkgc_pcnext(); } else { vm_commit(); stack[A] = call_nonfn(fiber, callee); vm_pcnext(); } } VM_OP(JOP_TAILCALL) { vm_maybe_auto_suspend(1); Janet callee = stack[D]; if (fiber->stacktop > fiber->maxstack) { vm_throw("stack overflow"); } if (janet_checktype(callee, JANET_KEYWORD)) { vm_commit(); callee = resolve_method(callee, fiber); } if (janet_checktype(callee, JANET_FUNCTION)) { func = janet_unwrap_function(callee); if (func->gc.flags & JANET_FUNCFLAG_TRACE) { vm_do_trace(func, fiber->stacktop - fiber->stackstart, fiber->data + fiber->stackstart); } if (janet_fiber_funcframe_tail(fiber, func)) { janet_stack_frame(fiber->data + fiber->frame)->pc = pc; int32_t n = fiber->stacktop - fiber->stackstart; janet_panicf("%v called with %d argument%s, expected %d", callee, n, n == 1 ? "" : "s", func->def->arity); } stack = fiber->data + fiber->frame; pc = func->def->bytecode; vm_checkgc_next(); } else { Janet retreg; int entrance_frame = janet_stack_frame(stack)->flags & JANET_STACKFRAME_ENTRANCE; vm_commit(); if (janet_checktype(callee, JANET_CFUNCTION)) { int32_t argc = fiber->stacktop - fiber->stackstart; janet_fiber_cframe(fiber, janet_unwrap_cfunction(callee)); retreg = janet_unwrap_cfunction(callee)(argc, fiber->data + fiber->frame); janet_fiber_popframe(fiber); } else { retreg = call_nonfn(fiber, callee); } janet_fiber_popframe(fiber); if (entrance_frame) { vm_return_no_restore(JANET_SIGNAL_OK, retreg); } vm_restore(); stack[A] = retreg; vm_checkgc_pcnext(); } } VM_OP(JOP_RESUME) { Janet retreg; vm_maybe_auto_suspend(1); vm_assert_type(stack[B], JANET_FIBER); JanetFiber *child = janet_unwrap_fiber(stack[B]); if (janet_check_can_resume(child, &retreg, 0)) { vm_commit(); janet_panicv(retreg); } fiber->child = child; JanetSignal sig = janet_continue_no_check(child, stack[C], &retreg); if (sig != JANET_SIGNAL_OK && !(child->flags & (1 << sig))) { vm_return(sig, retreg); } fiber->child = NULL; stack = fiber->data + fiber->frame; stack[A] = retreg; vm_checkgc_pcnext(); } VM_OP(JOP_SIGNAL) { int32_t s = C; if (s > JANET_SIGNAL_USER9) s = JANET_SIGNAL_USER9; if (s < 0) s = 0; vm_return(s, stack[B]); } VM_OP(JOP_PROPAGATE) { Janet fv = stack[C]; vm_assert_type(fv, JANET_FIBER); JanetFiber *f = janet_unwrap_fiber(fv); JanetFiberStatus sub_status = janet_fiber_status(f); if (sub_status > JANET_STATUS_USER9) { vm_commit(); janet_panicf("cannot propagate from fiber with status :%s", janet_status_names[sub_status]); } fiber->child = f; vm_return((int) sub_status, stack[B]); } VM_OP(JOP_CANCEL) { Janet retreg; vm_assert_type(stack[B], JANET_FIBER); JanetFiber *child = janet_unwrap_fiber(stack[B]); if (janet_check_can_resume(child, &retreg, 1)) { vm_commit(); janet_panicv(retreg); } fiber->child = child; JanetSignal sig = janet_continue_signal(child, stack[C], &retreg, JANET_SIGNAL_ERROR); if (sig != JANET_SIGNAL_OK && !(child->flags & (1 << sig))) { vm_return(sig, retreg); } fiber->child = NULL; stack = fiber->data + fiber->frame; stack[A] = retreg; vm_checkgc_pcnext(); } VM_OP(JOP_PUT) vm_commit(); fiber->flags |= JANET_FIBER_RESUME_NO_USEVAL; janet_put(stack[A], stack[B], stack[C]); stack = fiber->data + fiber->frame; fiber->flags &= ~JANET_FIBER_RESUME_NO_USEVAL; vm_checkgc_pcnext(); VM_OP(JOP_PUT_INDEX) vm_commit(); fiber->flags |= JANET_FIBER_RESUME_NO_USEVAL; janet_putindex(stack[A], C, stack[B]); stack = fiber->data + fiber->frame; fiber->flags &= ~JANET_FIBER_RESUME_NO_USEVAL; vm_checkgc_pcnext(); VM_OP(JOP_IN) vm_commit(); { Janet a = janet_in(stack[B], stack[C]); stack = fiber->data + fiber->frame; stack[A] = a; } vm_pcnext(); VM_OP(JOP_GET) vm_commit(); { Janet a = janet_get(stack[B], stack[C]); stack = fiber->data + fiber->frame; stack[A] = a; } vm_pcnext(); VM_OP(JOP_GET_INDEX) vm_commit(); { Janet a = janet_getindex(stack[B], C); stack = fiber->data + fiber->frame; stack[A] = a; } vm_pcnext(); VM_OP(JOP_LENGTH) vm_commit(); { Janet a = janet_lengthv(stack[E]); stack = fiber->data + fiber->frame; stack[A] = a; } vm_pcnext(); VM_OP(JOP_MAKE_ARRAY) { int32_t count = fiber->stacktop - fiber->stackstart; Janet *mem = fiber->data + fiber->stackstart; stack[D] = janet_wrap_array(janet_array_n(mem, count)); fiber->stacktop = fiber->stackstart; vm_checkgc_pcnext(); } VM_OP(JOP_MAKE_TUPLE) /* fallthrough */ VM_OP(JOP_MAKE_BRACKET_TUPLE) { int32_t count = fiber->stacktop - fiber->stackstart; Janet *mem = fiber->data + fiber->stackstart; const Janet *tup = janet_tuple_n(mem, count); if (opcode == JOP_MAKE_BRACKET_TUPLE) janet_tuple_flag(tup) |= JANET_TUPLE_FLAG_BRACKETCTOR; stack[D] = janet_wrap_tuple(tup); fiber->stacktop = fiber->stackstart; vm_checkgc_pcnext(); } VM_OP(JOP_MAKE_TABLE) { int32_t count = fiber->stacktop - fiber->stackstart; Janet *mem = fiber->data + fiber->stackstart; if (count & 1) { vm_commit(); janet_panicf("expected even number of arguments to table constructor, got %d", count); } JanetTable *table = janet_table(count / 2); for (int32_t i = 0; i < count; i += 2) janet_table_put(table, mem[i], mem[i + 1]); stack[D] = janet_wrap_table(table); fiber->stacktop = fiber->stackstart; vm_checkgc_pcnext(); } VM_OP(JOP_MAKE_STRUCT) { int32_t count = fiber->stacktop - fiber->stackstart; Janet *mem = fiber->data + fiber->stackstart; if (count & 1) { vm_commit(); janet_panicf("expected even number of arguments to struct constructor, got %d", count); } JanetKV *st = janet_struct_begin(count / 2); for (int32_t i = 0; i < count; i += 2) janet_struct_put(st, mem[i], mem[i + 1]); stack[D] = janet_wrap_struct(janet_struct_end(st)); fiber->stacktop = fiber->stackstart; vm_checkgc_pcnext(); } VM_OP(JOP_MAKE_STRING) { int32_t count = fiber->stacktop - fiber->stackstart; Janet *mem = fiber->data + fiber->stackstart; JanetBuffer buffer; janet_buffer_init(&buffer, 10 * count); for (int32_t i = 0; i < count; i++) janet_to_string_b(&buffer, mem[i]); stack[D] = janet_stringv(buffer.data, buffer.count); janet_buffer_deinit(&buffer); fiber->stacktop = fiber->stackstart; vm_checkgc_pcnext(); } VM_OP(JOP_MAKE_BUFFER) { int32_t count = fiber->stacktop - fiber->stackstart; Janet *mem = fiber->data + fiber->stackstart; JanetBuffer *buffer = janet_buffer(10 * count); for (int32_t i = 0; i < count; i++) janet_to_string_b(buffer, mem[i]); stack[D] = janet_wrap_buffer(buffer); fiber->stacktop = fiber->stackstart; vm_checkgc_pcnext(); } VM_END() } /* * Execute a single instruction in the fiber. Does this by inspecting * the fiber, setting a breakpoint at the next instruction, executing, and * resetting breakpoints to how they were prior. Yes, it's a bit hacky. */ JanetSignal janet_step(JanetFiber *fiber, Janet in, Janet *out) { /* No finished or currently alive fibers. */ JanetFiberStatus status = janet_fiber_status(fiber); if (status == JANET_STATUS_ALIVE || status == JANET_STATUS_DEAD || status == JANET_STATUS_ERROR) { janet_panicf("cannot step fiber with status :%s", janet_status_names[status]); } /* Get PC for setting breakpoints */ uint32_t *pc = janet_stack_frame(fiber->data + fiber->frame)->pc; /* Check current opcode (sans debug flag). This tells us where the next or next two candidate * instructions will be. Usually it's the next instruction in memory, * but for branching instructions it is also the target of the branch. */ uint32_t *nexta = NULL, *nextb = NULL, olda = 0, oldb = 0; /* Set temporary breakpoints */ switch (*pc & 0x7F) { default: nexta = pc + 1; break; /* These we just ignore for now. Supporting them means * we could step into and out of functions (including JOP_CALL). */ case JOP_RETURN_NIL: case JOP_RETURN: case JOP_ERROR: case JOP_TAILCALL: break; case JOP_JUMP: nexta = pc + DS; break; case JOP_JUMP_IF: case JOP_JUMP_IF_NOT: nexta = pc + 1; nextb = pc + ES; break; } if (nexta) { olda = *nexta; *nexta |= 0x80; } if (nextb) { oldb = *nextb; *nextb |= 0x80; } /* Go */ JanetSignal signal = janet_continue(fiber, in, out); /* Restore */ if (nexta) *nexta = olda; if (nextb) *nextb = oldb; return signal; } static Janet void_cfunction(int32_t argc, Janet *argv) { (void) argc; (void) argv; janet_panic("placeholder"); } Janet janet_call(JanetFunction *fun, int32_t argc, const Janet *argv) { /* Check entry conditions */ if (!janet_vm.fiber) janet_panic("janet_call failed because there is no current fiber"); if (janet_vm.stackn >= JANET_RECURSION_GUARD) janet_panic("C stack recursed too deeply"); /* Dirty stack */ int32_t dirty_stack = janet_vm.fiber->stacktop - janet_vm.fiber->stackstart; if (dirty_stack) { janet_fiber_cframe(janet_vm.fiber, void_cfunction); } /* Tracing */ if (fun->gc.flags & JANET_FUNCFLAG_TRACE) { janet_vm.stackn++; vm_do_trace(fun, argc, argv); janet_vm.stackn--; } /* Push frame */ janet_fiber_pushn(janet_vm.fiber, argv, argc); if (janet_fiber_funcframe(janet_vm.fiber, fun)) { int32_t min = fun->def->min_arity; int32_t max = fun->def->max_arity; Janet funv = janet_wrap_function(fun); if (min == max && min != argc) janet_panicf("arity mismatch in %v, expected %d, got %d", funv, min, argc); if (min >= 0 && argc < min) janet_panicf("arity mismatch in %v, expected at least %d, got %d", funv, min, argc); janet_panicf("arity mismatch in %v, expected at most %d, got %d", funv, max, argc); } janet_fiber_frame(janet_vm.fiber)->flags |= JANET_STACKFRAME_ENTRANCE; /* Set up */ int32_t oldn = janet_vm.stackn++; int handle = janet_gclock(); /* Run vm */ janet_vm.fiber->flags |= JANET_FIBER_RESUME_NO_USEVAL | JANET_FIBER_RESUME_NO_SKIP; int old_coerce_error = janet_vm.coerce_error; janet_vm.coerce_error = 1; JanetSignal signal = run_vm(janet_vm.fiber, janet_wrap_nil()); janet_vm.coerce_error = old_coerce_error; /* Teardown */ janet_vm.stackn = oldn; janet_gcunlock(handle); if (dirty_stack) { janet_fiber_popframe(janet_vm.fiber); janet_vm.fiber->stacktop += dirty_stack; } if (signal != JANET_SIGNAL_OK) { /* Should match logic in janet_signalv */ #ifdef JANET_EV if (janet_vm.root_fiber != NULL && signal == JANET_SIGNAL_EVENT) { janet_vm.root_fiber->sched_id++; } #endif if (signal != JANET_SIGNAL_ERROR) { *janet_vm.return_reg = janet_wrap_string(janet_formatc("%v coerced from %s to error", *janet_vm.return_reg, janet_signal_names[signal])); } janet_panicv(*janet_vm.return_reg); } return *janet_vm.return_reg; } static JanetSignal janet_check_can_resume(JanetFiber *fiber, Janet *out, int is_cancel) { /* Check conditions */ JanetFiberStatus old_status = janet_fiber_status(fiber); if (janet_vm.stackn >= JANET_RECURSION_GUARD) { janet_fiber_set_status(fiber, JANET_STATUS_ERROR); *out = janet_cstringv("C stack recursed too deeply"); return JANET_SIGNAL_ERROR; } /* If a "task" fiber is trying to be used as a normal fiber, detect that. See bug #920. * Fibers must be marked as root fibers manually, or by the ev scheduler. */ if (janet_vm.fiber != NULL && (fiber->gc.flags & JANET_FIBER_FLAG_ROOT)) { #ifdef JANET_EV *out = janet_cstringv(is_cancel ? "cannot cancel root fiber, use ev/cancel" : "cannot resume root fiber, use ev/go"); #else *out = janet_cstringv(is_cancel ? "cannot cancel root fiber" : "cannot resume root fiber"); #endif return JANET_SIGNAL_ERROR; } if (old_status == JANET_STATUS_ALIVE || old_status == JANET_STATUS_DEAD || (old_status >= JANET_STATUS_USER0 && old_status <= JANET_STATUS_USER4) || old_status == JANET_STATUS_ERROR) { const uint8_t *str = janet_formatc("cannot resume fiber with status :%s", janet_status_names[old_status]); *out = janet_wrap_string(str); return JANET_SIGNAL_ERROR; } return JANET_SIGNAL_OK; } void janet_try_init(JanetTryState *state) { state->stackn = janet_vm.stackn++; state->gc_handle = janet_vm.gc_suspend; state->vm_fiber = janet_vm.fiber; state->vm_jmp_buf = janet_vm.signal_buf; state->vm_return_reg = janet_vm.return_reg; state->coerce_error = janet_vm.coerce_error; janet_vm.return_reg = &(state->payload); janet_vm.signal_buf = &(state->buf); janet_vm.coerce_error = 0; } void janet_restore(JanetTryState *state) { janet_vm.stackn = state->stackn; janet_vm.gc_suspend = state->gc_handle; janet_vm.fiber = state->vm_fiber; janet_vm.signal_buf = state->vm_jmp_buf; janet_vm.return_reg = state->vm_return_reg; janet_vm.coerce_error = state->coerce_error; } static JanetSignal janet_continue_no_check(JanetFiber *fiber, Janet in, Janet *out) { JanetFiberStatus old_status = janet_fiber_status(fiber); #ifdef JANET_EV janet_fiber_did_resume(fiber); #endif /* Clear last value */ fiber->last_value = janet_wrap_nil(); /* Continue child fiber if it exists */ if (fiber->child) { if (janet_vm.root_fiber == NULL) janet_vm.root_fiber = fiber; JanetFiber *child = fiber->child; uint32_t instr = (janet_stack_frame(fiber->data + fiber->frame)->pc)[0]; janet_vm.stackn++; JanetSignal sig = janet_continue(child, in, &in); janet_vm.stackn--; if (janet_vm.root_fiber == fiber) janet_vm.root_fiber = NULL; if (sig != JANET_SIGNAL_OK && !(child->flags & (1 << sig))) { *out = in; janet_fiber_set_status(fiber, sig); fiber->last_value = child->last_value; return sig; } /* Check if we need any special handling for certain opcodes */ switch (instr & 0x7F) { default: break; case JOP_NEXT: { if (sig == JANET_SIGNAL_OK || sig == JANET_SIGNAL_ERROR || sig == JANET_SIGNAL_USER0 || sig == JANET_SIGNAL_USER1 || sig == JANET_SIGNAL_USER2 || sig == JANET_SIGNAL_USER3 || sig == JANET_SIGNAL_USER4) { in = janet_wrap_nil(); } else { in = janet_wrap_integer(0); } break; } } fiber->child = NULL; } /* Handle new fibers being resumed with a non-nil value */ if (old_status == JANET_STATUS_NEW && !janet_checktype(in, JANET_NIL)) { Janet *stack = fiber->data + fiber->frame; JanetFunction *func = janet_stack_frame(stack)->func; if (func) { if (func->def->arity > 0) { stack[0] = in; } else if (func->def->flags & JANET_FUNCDEF_FLAG_VARARG) { stack[0] = janet_wrap_tuple(janet_tuple_n(&in, 1)); } } } /* Save global state */ JanetTryState tstate; JanetSignal sig = janet_try(&tstate); if (!sig) { /* Normal setup */ if (janet_vm.root_fiber == NULL) janet_vm.root_fiber = fiber; janet_vm.fiber = fiber; janet_fiber_set_status(fiber, JANET_STATUS_ALIVE); sig = run_vm(fiber, in); } /* Restore */ if (janet_vm.root_fiber == fiber) janet_vm.root_fiber = NULL; janet_fiber_set_status(fiber, sig); janet_restore(&tstate); fiber->last_value = tstate.payload; *out = tstate.payload; return sig; } /* Enter the main vm loop */ JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out) { /* Check conditions */ JanetSignal tmp_signal = janet_check_can_resume(fiber, out, 0); if (tmp_signal) return tmp_signal; return janet_continue_no_check(fiber, in, out); } /* Enter the main vm loop but immediately raise a signal */ JanetSignal janet_continue_signal(JanetFiber *fiber, Janet in, Janet *out, JanetSignal sig) { JanetSignal tmp_signal = janet_check_can_resume(fiber, out, sig != JANET_SIGNAL_OK); if (tmp_signal) return tmp_signal; if (sig != JANET_SIGNAL_OK) { JanetFiber *child = fiber; while (child->child) child = child->child; child->gc.flags &= ~JANET_FIBER_STATUS_MASK; child->gc.flags |= sig << JANET_FIBER_STATUS_OFFSET; child->flags |= JANET_FIBER_RESUME_SIGNAL; } return janet_continue_no_check(fiber, in, out); } JanetSignal janet_pcall( JanetFunction *fun, int32_t argc, const Janet *argv, Janet *out, JanetFiber **f) { JanetFiber *fiber; if (f && *f) { fiber = janet_fiber_reset(*f, fun, argc, argv); } else { fiber = janet_fiber(fun, 64, argc, argv); } if (f) *f = fiber; if (NULL == fiber) { *out = janet_cstringv("arity mismatch"); return JANET_SIGNAL_ERROR; } return janet_continue(fiber, janet_wrap_nil(), out); } Janet janet_mcall(const char *name, int32_t argc, Janet *argv) { /* At least 1 argument */ if (argc < 1) { janet_panicf("method :%s expected at least 1 argument", name); } /* Find method */ Janet method = janet_method_lookup(argv[0], name); if (janet_checktype(method, JANET_NIL)) { janet_panicf("could not find method :%s for %v", name, argv[0]); } /* Invoke method */ return janet_method_invoke(method, argc, argv); } /* Setup VM */ int janet_init(void) { /* Garbage collection */ janet_vm.blocks = NULL; janet_vm.weak_blocks = NULL; janet_vm.next_collection = 0; janet_vm.gc_interval = 0x400000; janet_vm.block_count = 0; janet_vm.gc_mark_phase = 0; janet_symcache_init(); /* Initialize gc roots */ janet_vm.roots = NULL; janet_vm.root_count = 0; janet_vm.root_capacity = 0; /* Scratch memory */ janet_vm.user = NULL; janet_vm.scratch_mem = NULL; janet_vm.scratch_len = 0; janet_vm.scratch_cap = 0; /* Sandbox flags */ janet_vm.sandbox_flags = 0; /* Initialize registry */ janet_vm.registry = NULL; janet_vm.registry_cap = 0; janet_vm.registry_count = 0; janet_vm.registry_dirty = 0; /* Initialize abstract registry */ janet_vm.abstract_registry = janet_table(0); janet_gcroot(janet_wrap_table(janet_vm.abstract_registry)); /* Traversal */ janet_vm.traversal = NULL; janet_vm.traversal_base = NULL; janet_vm.traversal_top = NULL; /* Core env */ janet_vm.core_env = NULL; /* Auto suspension */ janet_vm.auto_suspend = 0; /* Dynamic bindings */ janet_vm.top_dyns = NULL; /* Seed RNG */ janet_rng_seed(janet_default_rng(), 0); /* Fibers */ janet_vm.fiber = NULL; janet_vm.root_fiber = NULL; janet_vm.stackn = 0; #ifdef JANET_EV janet_ev_init(); #endif #ifdef JANET_NET janet_net_init(); #endif return 0; } /* Disable some features at runtime with no way to re-enable them */ void janet_sandbox(uint32_t flags) { janet_sandbox_assert(JANET_SANDBOX_SANDBOX); janet_vm.sandbox_flags |= flags; } void janet_sandbox_assert(uint32_t forbidden_flags) { if (forbidden_flags & janet_vm.sandbox_flags) { janet_panic("operation forbidden by sandbox"); } } /* Clear all memory associated with the VM */ void janet_deinit(void) { janet_clear_memory(); janet_symcache_deinit(); janet_free(janet_vm.roots); janet_vm.roots = NULL; janet_vm.root_count = 0; janet_vm.root_capacity = 0; janet_vm.abstract_registry = NULL; janet_vm.core_env = NULL; janet_vm.top_dyns = NULL; janet_vm.user = NULL; janet_free(janet_vm.traversal_base); janet_vm.fiber = NULL; janet_vm.root_fiber = NULL; janet_free(janet_vm.registry); janet_vm.registry = NULL; #ifdef JANET_EV janet_ev_deinit(); #endif #ifdef JANET_NET janet_net_deinit(); #endif } janet-1.41.2/src/core/wrap.c000066400000000000000000000177351514534607600155640ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #ifndef JANET_AMALG #include "features.h" #include #include #include "util.h" #include "state.h" #endif /* Macro fills */ JanetType(janet_type)(Janet x) { return janet_type(x); } int (janet_checktype)(Janet x, JanetType type) { return janet_checktype(x, type); } int (janet_checktypes)(Janet x, int typeflags) { return janet_checktypes(x, typeflags); } int (janet_truthy)(Janet x) { return janet_truthy(x); } JanetStruct(janet_unwrap_struct)(Janet x) { return janet_unwrap_struct(x); } JanetTuple(janet_unwrap_tuple)(Janet x) { return janet_unwrap_tuple(x); } JanetFiber *(janet_unwrap_fiber)(Janet x) { return janet_unwrap_fiber(x); } JanetArray *(janet_unwrap_array)(Janet x) { return janet_unwrap_array(x); } JanetTable *(janet_unwrap_table)(Janet x) { return janet_unwrap_table(x); } JanetBuffer *(janet_unwrap_buffer)(Janet x) { return janet_unwrap_buffer(x); } JanetString(janet_unwrap_string)(Janet x) { return janet_unwrap_string(x); } JanetSymbol(janet_unwrap_symbol)(Janet x) { return janet_unwrap_symbol(x); } JanetKeyword(janet_unwrap_keyword)(Janet x) { return janet_unwrap_keyword(x); } JanetAbstract(janet_unwrap_abstract)(Janet x) { return janet_unwrap_abstract(x); } void *(janet_unwrap_pointer)(Janet x) { return janet_unwrap_pointer(x); } JanetFunction *(janet_unwrap_function)(Janet x) { return janet_unwrap_function(x); } JanetCFunction(janet_unwrap_cfunction)(Janet x) { return janet_unwrap_cfunction(x); } int (janet_unwrap_boolean)(Janet x) { return janet_unwrap_boolean(x); } int32_t (janet_unwrap_integer)(Janet x) { return janet_unwrap_integer(x); } #if defined(JANET_NANBOX_32) || defined(JANET_NANBOX_64) Janet(janet_wrap_nil)(void) { return janet_wrap_nil(); } Janet(janet_wrap_true)(void) { return janet_wrap_true(); } Janet(janet_wrap_false)(void) { return janet_wrap_false(); } Janet(janet_wrap_boolean)(int x) { return janet_wrap_boolean(x); } Janet(janet_wrap_string)(JanetString x) { return janet_wrap_string(x); } Janet(janet_wrap_symbol)(JanetSymbol x) { return janet_wrap_symbol(x); } Janet(janet_wrap_keyword)(JanetKeyword x) { return janet_wrap_keyword(x); } Janet(janet_wrap_array)(JanetArray *x) { return janet_wrap_array(x); } Janet(janet_wrap_tuple)(JanetTuple x) { return janet_wrap_tuple(x); } Janet(janet_wrap_struct)(JanetStruct x) { return janet_wrap_struct(x); } Janet(janet_wrap_fiber)(JanetFiber *x) { return janet_wrap_fiber(x); } Janet(janet_wrap_buffer)(JanetBuffer *x) { return janet_wrap_buffer(x); } Janet(janet_wrap_function)(JanetFunction *x) { return janet_wrap_function(x); } Janet(janet_wrap_cfunction)(JanetCFunction x) { return janet_wrap_cfunction(x); } Janet(janet_wrap_table)(JanetTable *x) { return janet_wrap_table(x); } Janet(janet_wrap_abstract)(JanetAbstract x) { return janet_wrap_abstract(x); } Janet(janet_wrap_pointer)(void *x) { return janet_wrap_pointer(x); } Janet(janet_wrap_integer)(int32_t x) { return janet_wrap_integer(x); } #endif #ifndef JANET_NANBOX_32 double (janet_unwrap_number)(Janet x) { return janet_unwrap_number(x); } #endif #ifdef JANET_NANBOX_64 Janet(janet_wrap_number)(double x) { return janet_wrap_number(x); } #endif /*****/ void *janet_memalloc_empty(int32_t count) { int32_t i; void *mem = janet_malloc((size_t) count * sizeof(JanetKV)); janet_vm.next_collection += (size_t) count * sizeof(JanetKV); if (NULL == mem) { JANET_OUT_OF_MEMORY; } JanetKV *mmem = (JanetKV *)mem; for (i = 0; i < count; i++) { JanetKV *kv = mmem + i; kv->key = janet_wrap_nil(); kv->value = janet_wrap_nil(); } return mem; } void janet_memempty(JanetKV *mem, int32_t count) { int32_t i; for (i = 0; i < count; i++) { mem[i].key = janet_wrap_nil(); mem[i].value = janet_wrap_nil(); } } #ifdef JANET_NANBOX_64 Janet janet_wrap_number_safe(double d) { Janet ret; ret.number = isnan(d) ? NAN : d; return ret; } void *janet_nanbox_to_pointer(Janet x) { x.i64 &= JANET_NANBOX_PAYLOADBITS; return x.pointer; } Janet janet_nanbox_from_pointer(void *p, uint64_t tagmask) { Janet ret; ret.pointer = p; ret.u64 |= tagmask; return ret; } Janet janet_nanbox_from_cpointer(const void *p, uint64_t tagmask) { Janet ret; ret.pointer = (void *)p; ret.u64 |= tagmask; return ret; } Janet janet_nanbox_from_double(double d) { Janet ret; ret.number = d; return ret; } Janet janet_nanbox_from_bits(uint64_t bits) { Janet ret; ret.u64 = bits; return ret; } #elif defined(JANET_NANBOX_32) Janet janet_wrap_number(double x) { Janet ret; ret.number = x; ret.tagged.type += JANET_DOUBLE_OFFSET; return ret; } Janet janet_wrap_number_safe(double d) { double x = isnan(d) ? NAN : d; return janet_wrap_number(x); } Janet janet_nanbox32_from_tagi(uint32_t tag, int32_t integer) { Janet ret; ret.tagged.type = tag; ret.tagged.payload.integer = integer; return ret; } Janet janet_nanbox32_from_tagp(uint32_t tag, void *pointer) { Janet ret; ret.tagged.type = tag; ret.tagged.payload.pointer = pointer; return ret; } double janet_unwrap_number(Janet x) { x.tagged.type -= JANET_DOUBLE_OFFSET; return x.number; } #else Janet janet_wrap_number_safe(double d) { return janet_wrap_number(d); } Janet janet_wrap_nil(void) { Janet y; y.type = JANET_NIL; y.as.u64 = 0; return y; } Janet janet_wrap_true(void) { Janet y; y.type = JANET_BOOLEAN; y.as.u64 = 1; return y; } Janet janet_wrap_false(void) { Janet y; y.type = JANET_BOOLEAN; y.as.u64 = 0; return y; } Janet janet_wrap_boolean(int x) { Janet y; y.type = JANET_BOOLEAN; y.as.u64 = !!x; return y; } #define JANET_WRAP_DEFINE(NAME, TYPE, DTYPE, UM)\ Janet janet_wrap_##NAME(TYPE x) {\ Janet y;\ y.type = DTYPE;\ y.as.u64 = 0; /* zero other bits in case of 32 bit integer */ \ y.as.UM = x;\ return y;\ } JANET_WRAP_DEFINE(number, double, JANET_NUMBER, number) JANET_WRAP_DEFINE(string, const uint8_t *, JANET_STRING, cpointer) JANET_WRAP_DEFINE(symbol, const uint8_t *, JANET_SYMBOL, cpointer) JANET_WRAP_DEFINE(keyword, const uint8_t *, JANET_KEYWORD, cpointer) JANET_WRAP_DEFINE(array, JanetArray *, JANET_ARRAY, pointer) JANET_WRAP_DEFINE(tuple, const Janet *, JANET_TUPLE, cpointer) JANET_WRAP_DEFINE(struct, const JanetKV *, JANET_STRUCT, cpointer) JANET_WRAP_DEFINE(fiber, JanetFiber *, JANET_FIBER, pointer) JANET_WRAP_DEFINE(buffer, JanetBuffer *, JANET_BUFFER, pointer) JANET_WRAP_DEFINE(function, JanetFunction *, JANET_FUNCTION, pointer) JANET_WRAP_DEFINE(cfunction, JanetCFunction, JANET_CFUNCTION, pointer) JANET_WRAP_DEFINE(table, JanetTable *, JANET_TABLE, pointer) JANET_WRAP_DEFINE(abstract, void *, JANET_ABSTRACT, pointer) JANET_WRAP_DEFINE(pointer, void *, JANET_POINTER, pointer) #undef JANET_WRAP_DEFINE #endif janet-1.41.2/src/include/000077500000000000000000000000001514534607600151255ustar00rootroot00000000000000janet-1.41.2/src/include/janet.h000066400000000000000000002644661514534607600164210ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #include "janetconf.h" #ifndef JANET_H_defined #define JANET_H_defined #ifdef __cplusplus extern "C" { #endif /* Variable length arrays are ok */ #ifdef _MSC_VER #pragma warning( push ) #pragma warning( disable : 4200 ) #endif /***** START SECTION CONFIG *****/ #ifndef JANET_VERSION #define JANET_VERSION "latest" #endif #ifndef JANET_BUILD #define JANET_BUILD "local" #endif /* * Detect OS and endianness. * From webkit source. There is likely some extreneous * detection for unsupported platforms */ /* Check for any flavor of BSD (except apple) */ #if defined(__FreeBSD__) || defined(__DragonFly__) || \ defined(__NetBSD__) || defined(__OpenBSD__) #define JANET_BSD 1 #endif /* Check for macOS or OS X */ #if defined(__APPLE__) && defined(__MACH__) #define JANET_APPLE 1 #endif /* Check for Linux */ #ifdef __linux__ #define JANET_LINUX 1 #endif /* Check for Android */ #ifdef __ANDROID__ #define JANET_ANDROID 1 #endif /* Check for Cygwin */ #if defined(__CYGWIN__) #define JANET_CYGWIN 1 #endif /* Check for Illumos */ #if defined(__illumos__) #define JANET_ILLUMOS 1 #endif /* Check Unix */ #if defined(_AIX) \ || defined(__APPLE__) /* Darwin */ \ || defined(__FreeBSD__) || defined(__DragonFly__) \ || defined(__FreeBSD_kernel__) \ || defined(__GNU__) /* GNU/Hurd */ \ || defined(__HAIKU__) \ || defined(__linux__) \ || defined(__NetBSD__) \ || defined(__OpenBSD__) \ || defined(__QNXNTO__) \ || defined(sun) || defined(__sun) /* Solaris */ \ || defined(unix) || defined(__unix) || defined(__unix__) #define JANET_POSIX 1 #elif defined(__EMSCRIPTEN__) #define JANET_WEB 1 #elif defined(WIN32) || defined(_WIN32) #define JANET_WINDOWS 1 #endif /* Check if compiling with MSVC - else assume a GCC-like compiler by default */ #ifdef _MSC_VER #define JANET_MSVC #endif /* Check Mingw 32-bit and 64-bit */ #ifdef __MINGW32__ #define JANET_MINGW #endif /* Check 64-bit vs 32-bit */ #if ((defined(__x86_64__) || defined(_M_X64)) \ && (defined(JANET_POSIX) || defined(JANET_WINDOWS))) \ || (defined(_WIN64)) /* Windows 64 bit */ \ || (defined(__ia64__) && defined(__LP64__)) /* Itanium in LP64 mode */ \ || defined(__alpha__) /* DEC Alpha */ \ || (defined(__sparc__) && defined(__arch64__) || defined (__sparcv9)) /* BE */ \ || defined(__s390x__) /* S390 64-bit (BE) */ \ || (defined(__ppc64__) || defined(__PPC64__)) \ || defined(PLAN9_arm64) || defined(PLAN9_amd64) \ || defined(__aarch64__) /* ARM 64-bit */ \ || (defined(__riscv) && (__riscv_xlen == 64)) /* RISC-V 64-bit */ \ || defined(__loongarch64) /* LoongArch64 64-bit */ #define JANET_64 1 #else #define JANET_32 1 #endif /* Check big endian */ #if defined(__LITTLE_ENDIAN__) || \ (defined(__BYTE_ORDER__) && (__BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__)) /* If we know the target is LE, always use that - e.g. ppc64 little endian * defines the __LITTLE_ENDIAN__ macro in the ABI spec, so we can rely * on that and if that's not defined, fall back to big endian assumption */ #define JANET_LITTLE_ENDIAN 1 #elif defined(__MIPSEB__) /* MIPS 32-bit */ \ || defined(__ppc__) || defined(__PPC__) /* CPU(PPC) - PowerPC 32-bit */ \ || defined(__powerpc__) || defined(__powerpc) || defined(__POWERPC__) \ || defined(_M_PPC) || defined(__PPC) \ || defined(__ppc64__) || defined(__PPC64__) /* PowerPC 64-bit */ \ || defined(__sparc) /* Sparc 32bit */ \ || defined(__sparc__) /* Sparc 64-bit */ \ || defined(__s390x__) /* S390 64-bit */ \ || defined(__s390__) /* S390 32-bit */ \ || defined(__ARMEB__) /* ARM big endian */ \ || defined(__AARCH64EB__) /* ARM64 big endian */ \ || ((defined(__CC_ARM) || defined(__ARMCC__)) /* ARM RealView compiler */ \ && defined(__BIG_ENDIAN)) #define JANET_BIG_ENDIAN 1 #else #define JANET_LITTLE_ENDIAN 1 #endif /* Limits for converting doubles to 64 bit integers */ #define JANET_INTMAX_DOUBLE 9007199254740992.0 #define JANET_INTMIN_DOUBLE (-9007199254740992.0) #define JANET_INTMAX_INT64 9007199254740992 #define JANET_INTMIN_INT64 (-9007199254740992) /* Check emscripten */ #ifdef __EMSCRIPTEN__ #define JANET_NO_DYNAMIC_MODULES #define JANET_NO_PROCESSES #endif /* Check sun */ #if defined(__sun) && !defined(JANET_ILLUMOS) #define JANET_NO_UTC_MKTIME #endif /* Define how global janet state is declared */ /* Also enable the thread library only if not single-threaded */ #ifdef JANET_SINGLE_THREADED #define JANET_THREAD_LOCAL #elif !(defined(JANET_THREAD_LOCAL)) && defined(__GNUC__) #define JANET_THREAD_LOCAL __thread #elif !(defined(JANET_THREAD_LOCAL)) && defined(_MSC_BUILD) #define JANET_THREAD_LOCAL __declspec(thread) #elif !(defined(JANET_THREAD_LOCAL)) #define JANET_THREAD_LOCAL #endif /* Enable or disable dynamic module loading. Enabled by default. */ #ifndef JANET_NO_DYNAMIC_MODULES #define JANET_DYNAMIC_MODULES #endif /* Enable or disable the FFI library. Currently, FFI only enabled on * x86-64 operating systems. */ #ifndef JANET_NO_FFI #if !defined(__EMSCRIPTEN__) #define JANET_FFI #endif #endif /* If FFI is enabled and FFI-JIT is not disabled... */ #ifdef JANET_FFI #ifndef JANET_NO_FFI_JIT #define JANET_FFI_JIT #endif #endif /* Enable or disable the assembler. Enabled by default. */ #ifndef JANET_NO_ASSEMBLER #define JANET_ASSEMBLER #endif /* Enable or disable the peg module */ #ifndef JANET_NO_PEG #define JANET_PEG #endif /* Enable or disable event loop */ #if !defined(JANET_NO_EV) && !defined(__EMSCRIPTEN__) #define JANET_EV #endif /* Enable or disable the filewatch/ module */ #if !defined(JANET_NO_FILEWATCH) #define JANET_FILEWATCH #endif /* Enable or disable networking */ #if defined(JANET_EV) && !defined(JANET_NO_NET) && !defined(__EMSCRIPTEN__) #define JANET_NET #endif /* Enable or disable large int types (for now 64 bit, maybe 128 / 256 bit integer types) */ #ifndef JANET_NO_INT_TYPES #define JANET_INT_TYPES #endif /* Enable or disable epoll on Linux */ #if defined(JANET_LINUX) && !defined(JANET_EV_NO_EPOLL) #define JANET_EV_EPOLL #endif /* Enable or disable kqueue on BSD */ #if defined(JANET_BSD) && !defined(JANET_EV_NO_KQUEUE) #define JANET_EV_KQUEUE #endif /* Enable or disable kqueue on Apple */ #if defined(JANET_APPLE) && !defined(JANET_EV_NO_KQUEUE) #define JANET_EV_KQUEUE #endif /* Use poll as last resort */ #if !defined(JANET_WINDOWS) && !defined(JANET_EV_EPOLL) && !defined(JANET_EV_KQUEUE) #define JANET_EV_POLL #endif /* How to export symbols */ #ifndef JANET_EXPORT #ifdef JANET_WINDOWS #define JANET_EXPORT __declspec(dllexport) #else #define JANET_EXPORT __attribute__((visibility ("default"))) #endif #endif /* How declare API functions */ #ifndef JANET_API #ifdef JANET_WINDOWS #ifdef JANET_DLL_IMPORT #define JANET_API __declspec(dllimport) #else #define JANET_API __declspec(dllexport) #endif #else #define JANET_API __attribute__((visibility ("default"))) #endif #endif /* Tell compiler some functions don't return */ #ifndef JANET_NO_RETURN #ifdef JANET_WINDOWS #define JANET_NO_RETURN __declspec(noreturn) #else #define JANET_NO_RETURN __attribute__((noreturn)) #endif #endif /* Prevent some recursive functions from recursing too deeply * and crashing (the parser). Instead, error out. */ #define JANET_RECURSION_GUARD 1024 /* Maximum depth to follow table prototypes before giving up and returning nil. */ #define JANET_MAX_PROTO_DEPTH 200 /* Prevent macros to expand too deeply and error out. */ #define JANET_MAX_MACRO_EXPAND 200 /* Define default max stack size for stacks before raising a stack overflow error. * This can also be set on a per fiber basis. */ #ifndef JANET_STACK_MAX #define JANET_STACK_MAX 0x7fffffff #endif /* Use nanboxed values - uses 8 bytes per value instead of 12 or 16. * To turn of nanboxing, for debugging purposes or for certain * architectures (Nanboxing only tested on x86 and x64), comment out * the JANET_NANBOX define.*/ #if defined(_M_ARM64) || defined(_M_ARM) || defined(__aarch64__) #define JANET_NO_NANBOX #endif #ifndef JANET_NO_NANBOX #ifdef JANET_32 #define JANET_NANBOX_32 #elif defined(__x86_64__) || defined(_WIN64) || defined(__riscv) /* We will only enable nanboxing by default on 64 bit systems * for x64 and risc-v. This is mainly because the approach is tied to the * implicit 47 bit address space. Many arches allow/require this, but not all, * and it requires cooperation from the OS. ARM should also work in many configurations. */ #define JANET_NANBOX_64 #endif #endif /* Runtime config constants */ #ifdef JANET_NO_NANBOX #define JANET_NANBOX_BIT 0 #else #define JANET_NANBOX_BIT 0x1 #endif #ifdef JANET_SINGLE_THREADED #define JANET_SINGLE_THREADED_BIT 0x2 #else #define JANET_SINGLE_THREADED_BIT 0 #endif #define JANET_CURRENT_CONFIG_BITS \ (JANET_SINGLE_THREADED_BIT | \ JANET_NANBOX_BIT) /* Represents the settings used to compile Janet, as well as the version */ typedef struct { unsigned major; unsigned minor; unsigned patch; unsigned bits; } JanetBuildConfig; /* Get config of current compilation unit. */ #ifdef __cplusplus /* C++11 syntax */ #define janet_config_current() (JanetBuildConfig { \ JANET_VERSION_MAJOR, \ JANET_VERSION_MINOR, \ JANET_VERSION_PATCH, \ JANET_CURRENT_CONFIG_BITS }) #else /* C99 syntax */ #define janet_config_current() ((JanetBuildConfig){ \ JANET_VERSION_MAJOR, \ JANET_VERSION_MINOR, \ JANET_VERSION_PATCH, \ JANET_CURRENT_CONFIG_BITS }) #endif /* Some extra includes if EV is enabled */ #ifdef JANET_EV typedef struct JanetOSMutex JanetOSMutex; typedef struct JanetOSRWLock JanetOSRWLock; typedef struct JanetChannel JanetChannel; #endif /***** END SECTION CONFIG *****/ /***** START SECTION TYPES *****/ #ifdef JANET_WINDOWS /* Must be defined before including stdlib.h */ #define _CRT_RAND_S #endif #include #include #include #include #include #include #include /* What to do when out of memory */ #ifndef JANET_OUT_OF_MEMORY #define JANET_OUT_OF_MEMORY do { fprintf(stderr, "%s:%d - janet out of memory\n", __FILE__, __LINE__); exit(1); } while (0) #endif #ifdef JANET_BSD int _setjmp(jmp_buf); JANET_NO_RETURN void _longjmp(jmp_buf, int); #endif /* Names of all of the types */ JANET_API extern const char *const janet_type_names[16]; JANET_API extern const char *const janet_signal_names[14]; JANET_API extern const char *const janet_status_names[16]; /* For various IO routines, we want to use an int on posix and HANDLE on windows */ #ifdef JANET_WINDOWS typedef void *JanetHandle; #define JANET_HANDLE_NONE NULL #else typedef int JanetHandle; #define JANET_HANDLE_NONE (-1) #endif /* Fiber signals */ typedef enum { JANET_SIGNAL_OK, JANET_SIGNAL_ERROR, JANET_SIGNAL_DEBUG, JANET_SIGNAL_YIELD, JANET_SIGNAL_USER0, JANET_SIGNAL_USER1, JANET_SIGNAL_USER2, JANET_SIGNAL_USER3, JANET_SIGNAL_USER4, JANET_SIGNAL_USER5, JANET_SIGNAL_USER6, JANET_SIGNAL_USER7, JANET_SIGNAL_USER8, JANET_SIGNAL_USER9, JANET_SIGNAL_INTERRUPT = JANET_SIGNAL_USER8, JANET_SIGNAL_EVENT = JANET_SIGNAL_USER9, } JanetSignal; /* Fiber statuses - mostly corresponds to signals. */ typedef enum { JANET_STATUS_DEAD, JANET_STATUS_ERROR, JANET_STATUS_DEBUG, JANET_STATUS_PENDING, JANET_STATUS_USER0, JANET_STATUS_USER1, JANET_STATUS_USER2, JANET_STATUS_USER3, JANET_STATUS_USER4, JANET_STATUS_USER5, JANET_STATUS_USER6, JANET_STATUS_USER7, JANET_STATUS_USER8, JANET_STATUS_USER9, JANET_STATUS_NEW, JANET_STATUS_ALIVE } JanetFiberStatus; /* For encapsulating all thread-local Janet state (except natives) */ typedef struct JanetVM JanetVM; /* Use type punning for GC objects */ typedef struct JanetGCObject JanetGCObject; /* All of the primary Janet GCed types */ typedef struct JanetFunction JanetFunction; typedef struct JanetArray JanetArray; typedef struct JanetBuffer JanetBuffer; typedef struct JanetTable JanetTable; typedef struct JanetFiber JanetFiber; /* Prefixed Janet types */ typedef struct JanetTupleHead JanetTupleHead; typedef struct JanetStructHead JanetStructHead; typedef struct JanetStringHead JanetStringHead; typedef struct JanetAbstractHead JanetAbstractHead; /* Other structs */ typedef struct JanetFuncDef JanetFuncDef; typedef struct JanetFuncEnv JanetFuncEnv; typedef struct JanetKV JanetKV; typedef struct JanetStackFrame JanetStackFrame; typedef struct JanetAbstractType JanetAbstractType; typedef struct JanetReg JanetReg; typedef struct JanetRegExt JanetRegExt; typedef struct JanetMethod JanetMethod; typedef struct JanetSourceMapping JanetSourceMapping; typedef struct JanetSymbolMap JanetSymbolMap; typedef struct JanetView JanetView; typedef struct JanetByteView JanetByteView; typedef struct JanetDictView JanetDictView; typedef struct JanetRange JanetRange; typedef struct JanetRNG JanetRNG; /* Basic types for all Janet Values */ typedef enum JanetType { JANET_NUMBER, JANET_NIL, JANET_BOOLEAN, JANET_FIBER, JANET_STRING, JANET_SYMBOL, JANET_KEYWORD, JANET_ARRAY, JANET_TUPLE, JANET_TABLE, JANET_STRUCT, JANET_BUFFER, JANET_FUNCTION, JANET_CFUNCTION, JANET_ABSTRACT, JANET_POINTER } JanetType; /* Recursive type (Janet) */ #ifdef JANET_NANBOX_64 typedef union Janet Janet; union Janet { uint64_t u64; int64_t i64; double number; void *pointer; }; #elif defined(JANET_NANBOX_32) typedef union Janet Janet; union Janet { struct { #ifdef JANET_BIG_ENDIAN uint32_t type; union { int32_t integer; void *pointer; } payload; #else union { int32_t integer; void *pointer; } payload; uint32_t type; #endif } tagged; double number; uint64_t u64; }; #else typedef struct Janet Janet; struct Janet { union { uint64_t u64; double number; int32_t integer; void *pointer; const void *cpointer; } as; JanetType type; }; #endif /* C functions */ typedef Janet(*JanetCFunction)(int32_t argc, Janet *argv); /* String and other aliased pointer types */ typedef const uint8_t *JanetString; typedef const uint8_t *JanetSymbol; typedef const uint8_t *JanetKeyword; typedef const Janet *JanetTuple; typedef const JanetKV *JanetStruct; typedef void *JanetAbstract; #define JANET_COUNT_TYPES (JANET_POINTER + 1) /* Type flags */ #define JANET_TFLAG_NIL (1 << JANET_NIL) #define JANET_TFLAG_BOOLEAN (1 << JANET_BOOLEAN) #define JANET_TFLAG_FIBER (1 << JANET_FIBER) #define JANET_TFLAG_NUMBER (1 << JANET_NUMBER) #define JANET_TFLAG_STRING (1 << JANET_STRING) #define JANET_TFLAG_SYMBOL (1 << JANET_SYMBOL) #define JANET_TFLAG_KEYWORD (1 << JANET_KEYWORD) #define JANET_TFLAG_ARRAY (1 << JANET_ARRAY) #define JANET_TFLAG_TUPLE (1 << JANET_TUPLE) #define JANET_TFLAG_TABLE (1 << JANET_TABLE) #define JANET_TFLAG_STRUCT (1 << JANET_STRUCT) #define JANET_TFLAG_BUFFER (1 << JANET_BUFFER) #define JANET_TFLAG_FUNCTION (1 << JANET_FUNCTION) #define JANET_TFLAG_CFUNCTION (1 << JANET_CFUNCTION) #define JANET_TFLAG_ABSTRACT (1 << JANET_ABSTRACT) #define JANET_TFLAG_POINTER (1 << JANET_POINTER) #define JANET_TFLAG_BYTES (JANET_TFLAG_STRING | JANET_TFLAG_SYMBOL | JANET_TFLAG_BUFFER | JANET_TFLAG_KEYWORD) #define JANET_TFLAG_INDEXED (JANET_TFLAG_ARRAY | JANET_TFLAG_TUPLE) #define JANET_TFLAG_DICTIONARY (JANET_TFLAG_TABLE | JANET_TFLAG_STRUCT) #define JANET_TFLAG_LENGTHABLE (JANET_TFLAG_BYTES | JANET_TFLAG_INDEXED | JANET_TFLAG_DICTIONARY) #define JANET_TFLAG_CALLABLE (JANET_TFLAG_FUNCTION | JANET_TFLAG_CFUNCTION | \ JANET_TFLAG_LENGTHABLE | JANET_TFLAG_ABSTRACT) /* Event Loop Types */ #ifdef JANET_EV #define JANET_STREAM_CLOSED 0x1 #define JANET_STREAM_SOCKET 0x2 #define JANET_STREAM_UNREGISTERED 0x4 #define JANET_STREAM_READABLE 0x200 #define JANET_STREAM_WRITABLE 0x400 #define JANET_STREAM_ACCEPTABLE 0x800 #define JANET_STREAM_UDPSERVER 0x1000 #define JANET_STREAM_NOT_CLOSEABLE 0x2000 #define JANET_STREAM_TOCLOSE 0x10000 typedef enum { JANET_ASYNC_EVENT_INIT = 0, JANET_ASYNC_EVENT_MARK = 1, JANET_ASYNC_EVENT_DEINIT = 2, JANET_ASYNC_EVENT_CLOSE = 3, JANET_ASYNC_EVENT_ERR = 4, JANET_ASYNC_EVENT_HUP = 5, JANET_ASYNC_EVENT_READ = 6, JANET_ASYNC_EVENT_WRITE = 7, JANET_ASYNC_EVENT_COMPLETE = 8, /* Used on windows for IOCP */ JANET_ASYNC_EVENT_FAILED = 9 /* Used on windows for IOCP */ } JanetAsyncEvent; typedef enum { JANET_ASYNC_LISTEN_READ = 1, JANET_ASYNC_LISTEN_WRITE, JANET_ASYNC_LISTEN_BOTH } JanetAsyncMode; typedef struct JanetStream JanetStream; /* Wrapper around file descriptors and HANDLEs that can be polled. */ struct JanetStream { JanetHandle handle; uint32_t flags; uint32_t index; JanetFiber *read_fiber; JanetFiber *write_fiber; const void *methods; /* Methods for this stream */ }; typedef void (*JanetEVCallback)(JanetFiber *fiber, JanetAsyncEvent event); /* Start listening for events from a stream on the current root fiber. After * calling this, users should call janet_await() before returning from the * current C Function. This also will call janet_await. * mode is which events to listen for, and callback is the function pointer to * call when ever an event is sent from the event loop. state is an optional (can be NULL) * pointer to data allocated with janet_malloc. This pointer will be passed to callback as * fiber->ev_state. It will also be freed for you by the runtime when the event loop determines * it can no longer be referenced. On windows, the contents of state MUST contained an OVERLAPPED struct at the 0 offset. */ JANET_API void janet_async_start_fiber(JanetFiber *fiber, JanetStream *stream, JanetAsyncMode mode, JanetEVCallback callback, void *state); JANET_API JANET_NO_RETURN void janet_async_start(JanetStream *stream, JanetAsyncMode mode, JanetEVCallback callback, void *state); /* Do not send any more events to the given callback. Call this after scheduling fiber to be resume * or canceled. */ JANET_API void janet_async_end(JanetFiber *fiber); /* Needed for windows to mark a fiber as waiting for an IOCP completion event. Noop on other platforms. */ JANET_API void janet_async_in_flight(JanetFiber *fiber); /* On some platforms, it is important to be able to control if a stream is edge-trigger or level triggered. * For example, a server that is accepting connections might want to be level triggered or edge-triggered * depending on expected service. */ JANET_API void janet_stream_edge_triggered(JanetStream *stream); JANET_API void janet_stream_level_triggered(JanetStream *stream); #endif /* Janet uses atomic integers in several places for synchronization between threads and * signals. Define them here */ #ifdef JANET_WINDOWS typedef long JanetAtomicInt; #elif defined(JANET_PLAN9) typedef long JanetAtomicInt; #else typedef int32_t JanetAtomicInt; #endif JANET_API JanetAtomicInt janet_atomic_inc(JanetAtomicInt volatile *x); JANET_API JanetAtomicInt janet_atomic_dec(JanetAtomicInt volatile *x); JANET_API JanetAtomicInt janet_atomic_load(JanetAtomicInt volatile *x); JANET_API JanetAtomicInt janet_atomic_load_relaxed(JanetAtomicInt volatile *x); /* We provide three possible implementations of Janets. The preferred * nanboxing approach, for 32 or 64 bits, and the standard C version. Code in the rest of the * application must interact through exposed interface. */ /* Required interface for Janet */ /* wrap and unwrap for all types */ /* Get type quickly */ /* Check against type quickly */ /* Small footprint */ /* 32 bit integer support */ /* janet_type(x) * janet_checktype(x, t) * janet_wrap_##TYPE(x) * janet_unwrap_##TYPE(x) * janet_truthy(x) * janet_memclear(p, n) - clear memory for hash tables to nils * janet_u64(x) - get 64 bits of payload for hashing */ /***** START SECTION NON-C API *****/ /* Some janet types use offset tricks to make operations easier in C. For * external bindings, we should prefer using the Head structs directly, and * use the host language to add sugar around the manipulation of the Janet types. */ JANET_API JanetStructHead *janet_struct_head(JanetStruct st); JANET_API JanetAbstractHead *janet_abstract_head(const void *abstract); JANET_API JanetStringHead *janet_string_head(JanetString s); JANET_API JanetTupleHead *janet_tuple_head(JanetTuple tuple); /* Some language bindings won't have access to the macro versions. */ JANET_API JanetType janet_type(Janet x); JANET_API int janet_checktype(Janet x, JanetType type); JANET_API int janet_checktypes(Janet x, int typeflags); JANET_API int janet_truthy(Janet x); JANET_API JanetStruct janet_unwrap_struct(Janet x); JANET_API JanetTuple janet_unwrap_tuple(Janet x); JANET_API JanetFiber *janet_unwrap_fiber(Janet x); JANET_API JanetArray *janet_unwrap_array(Janet x); JANET_API JanetTable *janet_unwrap_table(Janet x); JANET_API JanetBuffer *janet_unwrap_buffer(Janet x); JANET_API JanetString janet_unwrap_string(Janet x); JANET_API JanetSymbol janet_unwrap_symbol(Janet x); JANET_API JanetKeyword janet_unwrap_keyword(Janet x); JANET_API JanetAbstract janet_unwrap_abstract(Janet x); JANET_API void *janet_unwrap_pointer(Janet x); JANET_API JanetFunction *janet_unwrap_function(Janet x); JANET_API JanetCFunction janet_unwrap_cfunction(Janet x); JANET_API int janet_unwrap_boolean(Janet x); JANET_API double janet_unwrap_number(Janet x); JANET_API int32_t janet_unwrap_integer(Janet x); JANET_API Janet janet_wrap_nil(void); JANET_API Janet janet_wrap_number(double x); JANET_API Janet janet_wrap_true(void); JANET_API Janet janet_wrap_false(void); JANET_API Janet janet_wrap_boolean(int x); JANET_API Janet janet_wrap_string(JanetString x); JANET_API Janet janet_wrap_symbol(JanetSymbol x); JANET_API Janet janet_wrap_keyword(JanetKeyword x); JANET_API Janet janet_wrap_array(JanetArray *x); JANET_API Janet janet_wrap_tuple(JanetTuple x); JANET_API Janet janet_wrap_struct(JanetStruct x); JANET_API Janet janet_wrap_fiber(JanetFiber *x); JANET_API Janet janet_wrap_buffer(JanetBuffer *x); JANET_API Janet janet_wrap_function(JanetFunction *x); JANET_API Janet janet_wrap_cfunction(JanetCFunction x); JANET_API Janet janet_wrap_table(JanetTable *x); JANET_API Janet janet_wrap_abstract(JanetAbstract x); JANET_API Janet janet_wrap_pointer(void *x); JANET_API Janet janet_wrap_integer(int32_t x); /***** END SECTION NON-C API *****/ #ifdef JANET_NANBOX_64 #include #define janet_u64(x) ((x).u64) #define JANET_NANBOX_TAGBITS 0xFFFF800000000000llu #define JANET_NANBOX_PAYLOADBITS 0x00007FFFFFFFFFFFllu #define janet_nanbox_lowtag(type) ((uint64_t)(type) | 0x1FFF0) #define janet_nanbox_tag(type) (janet_nanbox_lowtag(type) << 47) #define janet_type(x) \ (isnan((x).number) \ ? (JanetType) (((x).u64 >> 47) & 0xF) \ : JANET_NUMBER) #define janet_nanbox_checkauxtype(x, type) \ (((x).u64 & JANET_NANBOX_TAGBITS) == janet_nanbox_tag((type))) #define janet_nanbox_isnumber(x) \ (!isnan((x).number) || ((((x).u64 >> 47) & 0xF) == JANET_NUMBER)) #define janet_checktype(x, t) \ (((t) == JANET_NUMBER) \ ? janet_nanbox_isnumber(x) \ : janet_nanbox_checkauxtype((x), (t))) /* Use JANET_API so that modules will use a local version of these functions if possible */ JANET_API void *janet_nanbox_to_pointer(Janet x); JANET_API Janet janet_nanbox_from_pointer(void *p, uint64_t tagmask); JANET_API Janet janet_nanbox_from_cpointer(const void *p, uint64_t tagmask); JANET_API Janet janet_nanbox_from_double(double d); JANET_API Janet janet_nanbox_from_bits(uint64_t bits); #define janet_truthy(x) \ (!janet_checktype((x), JANET_NIL) && \ (!janet_checktype((x), JANET_BOOLEAN) || ((x).u64 & 0x1))) #define janet_nanbox_from_payload(t, p) \ janet_nanbox_from_bits(janet_nanbox_tag(t) | (p)) #define janet_nanbox_wrap_(p, t) \ janet_nanbox_from_pointer((p), janet_nanbox_tag(t)) #define janet_nanbox_wrap_c(p, t) \ janet_nanbox_from_cpointer((p), janet_nanbox_tag(t)) /* Wrap the simple types */ #define janet_wrap_nil() janet_nanbox_from_payload(JANET_NIL, 1) #define janet_wrap_true() janet_nanbox_from_payload(JANET_BOOLEAN, 1) #define janet_wrap_false() janet_nanbox_from_payload(JANET_BOOLEAN, 0) #define janet_wrap_boolean(b) janet_nanbox_from_payload(JANET_BOOLEAN, !!(b)) #define janet_wrap_number(r) janet_nanbox_from_double(r) /* Unwrap the simple types */ #define janet_unwrap_boolean(x) ((x).u64 & 0x1) #define janet_unwrap_number(x) ((x).number) /* Wrap the pointer types */ #define janet_wrap_struct(s) janet_nanbox_wrap_c((s), JANET_STRUCT) #define janet_wrap_tuple(s) janet_nanbox_wrap_c((s), JANET_TUPLE) #define janet_wrap_fiber(s) janet_nanbox_wrap_((s), JANET_FIBER) #define janet_wrap_array(s) janet_nanbox_wrap_((s), JANET_ARRAY) #define janet_wrap_table(s) janet_nanbox_wrap_((s), JANET_TABLE) #define janet_wrap_buffer(s) janet_nanbox_wrap_((s), JANET_BUFFER) #define janet_wrap_string(s) janet_nanbox_wrap_c((s), JANET_STRING) #define janet_wrap_symbol(s) janet_nanbox_wrap_c((s), JANET_SYMBOL) #define janet_wrap_keyword(s) janet_nanbox_wrap_c((s), JANET_KEYWORD) #define janet_wrap_abstract(s) janet_nanbox_wrap_((s), JANET_ABSTRACT) #define janet_wrap_function(s) janet_nanbox_wrap_((s), JANET_FUNCTION) #define janet_wrap_cfunction(s) janet_nanbox_wrap_((s), JANET_CFUNCTION) #define janet_wrap_pointer(s) janet_nanbox_wrap_((s), JANET_POINTER) /* Unwrap the pointer types */ #define janet_unwrap_struct(x) ((JanetStruct)janet_nanbox_to_pointer(x)) #define janet_unwrap_tuple(x) ((JanetTuple)janet_nanbox_to_pointer(x)) #define janet_unwrap_fiber(x) ((JanetFiber *)janet_nanbox_to_pointer(x)) #define janet_unwrap_array(x) ((JanetArray *)janet_nanbox_to_pointer(x)) #define janet_unwrap_table(x) ((JanetTable *)janet_nanbox_to_pointer(x)) #define janet_unwrap_buffer(x) ((JanetBuffer *)janet_nanbox_to_pointer(x)) #define janet_unwrap_string(x) ((JanetString)janet_nanbox_to_pointer(x)) #define janet_unwrap_symbol(x) ((JanetSymbol)janet_nanbox_to_pointer(x)) #define janet_unwrap_keyword(x) ((const uint8_t *)janet_nanbox_to_pointer(x)) #define janet_unwrap_abstract(x) (janet_nanbox_to_pointer(x)) #define janet_unwrap_pointer(x) (janet_nanbox_to_pointer(x)) #define janet_unwrap_function(x) ((JanetFunction *)janet_nanbox_to_pointer(x)) #define janet_unwrap_cfunction(x) ((JanetCFunction)janet_nanbox_to_pointer(x)) #elif defined(JANET_NANBOX_32) #define JANET_DOUBLE_OFFSET 0xFFFF #define janet_u64(x) ((x).u64) #define janet_type(x) (((x).tagged.type < JANET_DOUBLE_OFFSET) ? (JanetType)((x).tagged.type) : JANET_NUMBER) #define janet_checktype(x, t) ((t) == JANET_NUMBER \ ? (x).tagged.type >= JANET_DOUBLE_OFFSET \ : (x).tagged.type == (t)) #define janet_truthy(x) \ ((x).tagged.type != JANET_NIL && ((x).tagged.type != JANET_BOOLEAN || ((x).tagged.payload.integer & 0x1))) JANET_API Janet janet_nanbox32_from_tagi(uint32_t tag, int32_t integer); JANET_API Janet janet_nanbox32_from_tagp(uint32_t tag, void *pointer); #define janet_wrap_nil() janet_nanbox32_from_tagi(JANET_NIL, 0) #define janet_wrap_true() janet_nanbox32_from_tagi(JANET_BOOLEAN, 1) #define janet_wrap_false() janet_nanbox32_from_tagi(JANET_BOOLEAN, 0) #define janet_wrap_boolean(b) janet_nanbox32_from_tagi(JANET_BOOLEAN, !!(b)) /* Wrap the pointer types */ #define janet_wrap_struct(s) janet_nanbox32_from_tagp(JANET_STRUCT, (void *)(s)) #define janet_wrap_tuple(s) janet_nanbox32_from_tagp(JANET_TUPLE, (void *)(s)) #define janet_wrap_fiber(s) janet_nanbox32_from_tagp(JANET_FIBER, (void *)(s)) #define janet_wrap_array(s) janet_nanbox32_from_tagp(JANET_ARRAY, (void *)(s)) #define janet_wrap_table(s) janet_nanbox32_from_tagp(JANET_TABLE, (void *)(s)) #define janet_wrap_buffer(s) janet_nanbox32_from_tagp(JANET_BUFFER, (void *)(s)) #define janet_wrap_string(s) janet_nanbox32_from_tagp(JANET_STRING, (void *)(s)) #define janet_wrap_symbol(s) janet_nanbox32_from_tagp(JANET_SYMBOL, (void *)(s)) #define janet_wrap_keyword(s) janet_nanbox32_from_tagp(JANET_KEYWORD, (void *)(s)) #define janet_wrap_abstract(s) janet_nanbox32_from_tagp(JANET_ABSTRACT, (void *)(s)) #define janet_wrap_function(s) janet_nanbox32_from_tagp(JANET_FUNCTION, (void *)(s)) #define janet_wrap_cfunction(s) janet_nanbox32_from_tagp(JANET_CFUNCTION, (void *)(s)) #define janet_wrap_pointer(s) janet_nanbox32_from_tagp(JANET_POINTER, (void *)(s)) #define janet_unwrap_struct(x) ((JanetStruct)(x).tagged.payload.pointer) #define janet_unwrap_tuple(x) ((JanetTuple)(x).tagged.payload.pointer) #define janet_unwrap_fiber(x) ((JanetFiber *)(x).tagged.payload.pointer) #define janet_unwrap_array(x) ((JanetArray *)(x).tagged.payload.pointer) #define janet_unwrap_table(x) ((JanetTable *)(x).tagged.payload.pointer) #define janet_unwrap_buffer(x) ((JanetBuffer *)(x).tagged.payload.pointer) #define janet_unwrap_string(x) ((JanetString)(x).tagged.payload.pointer) #define janet_unwrap_symbol(x) ((JanetSymbol)(x).tagged.payload.pointer) #define janet_unwrap_keyword(x) ((JanetKeyword)(x).tagged.payload.pointer) #define janet_unwrap_abstract(x) ((x).tagged.payload.pointer) #define janet_unwrap_pointer(x) ((x).tagged.payload.pointer) #define janet_unwrap_function(x) ((JanetFunction *)(x).tagged.payload.pointer) #define janet_unwrap_cfunction(x) ((JanetCFunction)(x).tagged.payload.pointer) #define janet_unwrap_boolean(x) ((x).tagged.payload.integer) #else #define janet_u64(x) ((x).as.u64) #define janet_type(x) ((x).type) #define janet_checktype(x, t) ((x).type == (t)) #define janet_truthy(x) \ ((x).type != JANET_NIL && ((x).type != JANET_BOOLEAN || ((x).as.u64 & 0x1))) #define janet_unwrap_struct(x) ((JanetStruct)(x).as.pointer) #define janet_unwrap_tuple(x) ((JanetTuple)(x).as.pointer) #define janet_unwrap_fiber(x) ((JanetFiber *)(x).as.pointer) #define janet_unwrap_array(x) ((JanetArray *)(x).as.pointer) #define janet_unwrap_table(x) ((JanetTable *)(x).as.pointer) #define janet_unwrap_buffer(x) ((JanetBuffer *)(x).as.pointer) #define janet_unwrap_string(x) ((JanetString)(x).as.pointer) #define janet_unwrap_symbol(x) ((JanetSymbol)(x).as.pointer) #define janet_unwrap_keyword(x) ((JanetKeyword)(x).as.pointer) #define janet_unwrap_abstract(x) ((x).as.pointer) #define janet_unwrap_pointer(x) ((x).as.pointer) #define janet_unwrap_function(x) ((JanetFunction *)(x).as.pointer) #define janet_unwrap_cfunction(x) ((JanetCFunction)(x).as.pointer) #define janet_unwrap_boolean(x) ((x).as.u64 & 0x1) #define janet_unwrap_number(x) ((x).as.number) /* End of tagged union implementation */ #endif JANET_API int janet_checkint16(Janet x); JANET_API int janet_checkuint16(Janet x); JANET_API int janet_checkint(Janet x); JANET_API int janet_checkuint(Janet x); JANET_API int janet_checkint64(Janet x); JANET_API int janet_checkuint64(Janet x); JANET_API int janet_checksize(Janet x); JANET_API JanetAbstract janet_checkabstract(Janet x, const JanetAbstractType *at); #define janet_checkint16range(x) ((x) >= INT16_MIN && (x) <= INT16_MAX && (x) == (int16_t)(x)) #define janet_checkuint16range(x) ((x) >= 0 && (x) <= UINT16_MAX && (x) == (uint16_t)(x)) #define janet_checkintrange(x) ((x) >= INT32_MIN && (x) <= INT32_MAX && (x) == (int32_t)(x)) #define janet_checkuintrange(x) ((x) >= 0 && (x) <= UINT32_MAX && (x) == (uint32_t)(x)) #define janet_checkint64range(x) ((x) >= JANET_INTMIN_DOUBLE && (x) <= JANET_INTMAX_DOUBLE && (x) == (int64_t)(x)) #define janet_checkuint64range(x) ((x) >= 0 && (x) <= JANET_INTMAX_DOUBLE && (x) == (uint64_t)(x)) #define janet_unwrap_integer(x) ((int32_t) janet_unwrap_number(x)) #define janet_wrap_integer(x) janet_wrap_number((int32_t)(x)) #define janet_checktypes(x, tps) ((1 << janet_type(x)) & (tps)) /* GC Object type pun. The lower 16 bits of flags are reserved for the garbage collector, * but the upper 16 can be used per type for custom flags. The current collector is a linked * list of blocks, which is naive but works. */ struct JanetGCObject { int32_t flags; union { JanetGCObject *next; volatile JanetAtomicInt refcount; /* For threaded abstract types */ } data; }; /* A lightweight green thread in janet. Does not correspond to * operating system threads. */ struct JanetFiber { JanetGCObject gc; /* GC Object stuff */ int32_t flags; /* More flags */ int32_t frame; /* Index of the stack frame */ int32_t stackstart; /* Beginning of next args */ int32_t stacktop; /* Top of stack. Where values are pushed and popped from. */ int32_t capacity; /* How big is the stack memory */ int32_t maxstack; /* Arbitrary defined limit for stack overflow */ JanetTable *env; /* Dynamic bindings table (usually current environment). */ Janet *data; /* Dynamically resized stack memory */ JanetFiber *child; /* Keep linked list of fibers for restarting pending fibers */ Janet last_value; /* Last returned value from a fiber */ #ifdef JANET_EV /* These fields are only relevant for fibers that are used as "root fibers" - * that is, fibers that are scheduled on the event loop and behave much like threads * in a multi-tasking system. It would be possible to move these fields to a new * type, say "JanetTask", that as separate from fibers to save a bit of space. */ uint32_t sched_id; /* Increment everytime fiber is scheduled by event loop */ JanetEVCallback ev_callback; /* Call this before starting scheduled fibers */ JanetStream *ev_stream; /* which stream we are waiting on */ void *ev_state; /* Extra data for ev callback state. On windows, first element must be OVERLAPPED. */ void *supervisor_channel; /* Channel to push self to when complete */ #endif }; /* Mark if a stack frame is a tail call for debugging */ #define JANET_STACKFRAME_TAILCALL 1 /* Mark if a stack frame is an entrance frame */ #define JANET_STACKFRAME_ENTRANCE 2 /* A stack frame on the fiber. Is stored along with the stack values. */ struct JanetStackFrame { JanetFunction *func; uint32_t *pc; JanetFuncEnv *env; int32_t prevframe; int32_t flags; }; /* Number of Janets a frame takes up in the stack * Should be constant across architectures */ #define JANET_FRAME_SIZE 4 /* A dynamic array type. */ struct JanetArray { JanetGCObject gc; int32_t count; int32_t capacity; Janet *data; }; /* A byte buffer type. Used as a mutable string or string builder. */ struct JanetBuffer { JanetGCObject gc; int32_t count; int32_t capacity; uint8_t *data; }; /* A mutable associative data type. Backed by a hashtable. */ struct JanetTable { JanetGCObject gc; int32_t count; int32_t capacity; int32_t deleted; JanetKV *data; JanetTable *proto; }; /* A key value pair in a struct or table */ struct JanetKV { Janet key; Janet value; }; /* Prefix for a tuple */ struct JanetTupleHead { JanetGCObject gc; int32_t length; int32_t hash; int32_t sm_line; int32_t sm_column; const Janet data[]; }; /* Prefix for a struct */ struct JanetStructHead { JanetGCObject gc; int32_t length; int32_t hash; int32_t capacity; const JanetKV *proto; const JanetKV data[]; }; /* Prefix for a string */ struct JanetStringHead { JanetGCObject gc; int32_t length; int32_t hash; const uint8_t data[]; }; /* Prefix for an abstract value */ struct JanetAbstractHead { JanetGCObject gc; const JanetAbstractType *type; size_t size; long long data[]; /* Use long long to ensure most general alignment */ }; /* Some function definition flags */ #define JANET_FUNCDEF_FLAG_VARARG 0x10000 #define JANET_FUNCDEF_FLAG_NEEDSENV 0x20000 #define JANET_FUNCDEF_FLAG_HASSYMBOLMAP 0x40000 #define JANET_FUNCDEF_FLAG_HASNAME 0x80000 #define JANET_FUNCDEF_FLAG_HASSOURCE 0x100000 #define JANET_FUNCDEF_FLAG_HASDEFS 0x200000 #define JANET_FUNCDEF_FLAG_HASENVS 0x400000 #define JANET_FUNCDEF_FLAG_HASSOURCEMAP 0x800000 #define JANET_FUNCDEF_FLAG_STRUCTARG 0x1000000 #define JANET_FUNCDEF_FLAG_HASCLOBITSET 0x2000000 #define JANET_FUNCDEF_FLAG_NAMEDARGS 0x4000000 #define JANET_FUNCDEF_FLAG_TAG 0xFFFF /* Source mapping structure for a bytecode instruction */ struct JanetSourceMapping { int32_t line; int32_t column; }; /* Symbol to slot mapping & lifetime structure. */ struct JanetSymbolMap { uint32_t birth_pc; uint32_t death_pc; uint32_t slot_index; const uint8_t *symbol; }; /* A function definition. Contains information needed to instantiate closures. */ struct JanetFuncDef { JanetGCObject gc; int32_t *environments; /* Which environments to capture from parent. */ Janet *constants; JanetFuncDef **defs; uint32_t *bytecode; uint32_t *closure_bitset; /* Bit set indicating which slots can be referenced by closures. */ /* Various debug information */ JanetSourceMapping *sourcemap; JanetString source; JanetString name; JanetSymbolMap *symbolmap; int32_t flags; int32_t slotcount; /* The amount of stack space required for the function */ int32_t arity; /* Not including varargs */ int32_t min_arity; /* Including varargs */ int32_t max_arity; /* Including varargs */ int32_t constants_length; int32_t bytecode_length; int32_t environments_length; int32_t defs_length; int32_t symbolmap_length; int32_t named_args_count; }; /* A function environment */ struct JanetFuncEnv { JanetGCObject gc; union { JanetFiber *fiber; Janet *values; } as; int32_t length; /* Size of environment */ int32_t offset; /* Stack offset when values still on stack. If offset is <= 0, then environment is no longer on the stack. */ }; #define JANET_FUNCFLAG_TRACE (1 << 16) /* A function */ struct JanetFunction { JanetGCObject gc; JanetFuncDef *def; JanetFuncEnv *envs[]; }; /* Use to read Janet data structures into memory from source code */ typedef struct JanetParseState JanetParseState; typedef struct JanetParser JanetParser; typedef int (*Consumer)(JanetParser *p, JanetParseState *state, uint8_t c); struct JanetParseState { int32_t counter; int32_t argn; int flags; size_t line; size_t column; Consumer consumer; }; enum JanetParserStatus { JANET_PARSE_ROOT, JANET_PARSE_ERROR, JANET_PARSE_PENDING, JANET_PARSE_DEAD }; /* A janet parser */ struct JanetParser { Janet *args; const char *error; JanetParseState *states; uint8_t *buf; size_t argcount; size_t argcap; size_t statecount; size_t statecap; size_t bufcount; size_t bufcap; size_t line; size_t column; size_t pending; int lookback; int flag; }; /* A context for marshaling and unmarshaling abstract types */ typedef struct { void *m_state; void *u_state; int flags; const uint8_t *data; const JanetAbstractType *at; } JanetMarshalContext; /* Defines an abstract type. Use a const pointer to one of these structures * when creating abstract types. The memory for this pointer should not be free * until after janet_deinit is called. Usually, this means declaring JanetAbstractType's * as const data at file scope, and creating instances with janet_abstract(&MyType, sizeof(MyTypeStruct)); */ struct JanetAbstractType { const char *name; int (*gc)(void *data, size_t len); int (*gcmark)(void *data, size_t len); int (*get)(void *data, Janet key, Janet *out); void (*put)(void *data, Janet key, Janet value); void (*marshal)(void *p, JanetMarshalContext *ctx); void *(*unmarshal)(JanetMarshalContext *ctx); void (*tostring)(void *p, JanetBuffer *buffer); int (*compare)(void *lhs, void *rhs); int32_t (*hash)(void *p, size_t len); Janet(*next)(void *p, Janet key); Janet(*call)(void *p, int32_t argc, Janet *argv); size_t (*length)(void *p, size_t len); JanetByteView(*bytes)(void *p, size_t len); int (*gcperthread)(void *data, size_t len); }; /* Some macros to let us add extra types to JanetAbstract types without * needing to changing native modules that declare them as static const * structures. If more fields are added, these macros are modified to include * default values (usually NULL). This silences missing field warnings. */ #define JANET_ATEND_NAME NULL,JANET_ATEND_GC #define JANET_ATEND_GC NULL,JANET_ATEND_GCMARK #define JANET_ATEND_GCMARK NULL,JANET_ATEND_GET #define JANET_ATEND_GET NULL,JANET_ATEND_PUT #define JANET_ATEND_PUT NULL,JANET_ATEND_MARSHAL #define JANET_ATEND_MARSHAL NULL,JANET_ATEND_UNMARSHAL #define JANET_ATEND_UNMARSHAL NULL,JANET_ATEND_TOSTRING #define JANET_ATEND_TOSTRING NULL,JANET_ATEND_COMPARE #define JANET_ATEND_COMPARE NULL,JANET_ATEND_HASH #define JANET_ATEND_HASH NULL,JANET_ATEND_NEXT #define JANET_ATEND_NEXT NULL,JANET_ATEND_CALL #define JANET_ATEND_CALL NULL,JANET_ATEND_LENGTH #define JANET_ATEND_LENGTH NULL,JANET_ATEND_BYTES #define JANET_ATEND_BYTES NULL,JANET_ATEND_GCPERTHREAD #define JANET_ATEND_GCPERTHREAD struct JanetReg { const char *name; JanetCFunction cfun; const char *documentation; }; struct JanetRegExt { const char *name; JanetCFunction cfun; const char *documentation; const char *source_file; int32_t source_line; }; struct JanetMethod { const char *name; JanetCFunction cfun; }; struct JanetView { const Janet *items; int32_t len; }; struct JanetByteView { const uint8_t *bytes; int32_t len; }; struct JanetDictView { const JanetKV *kvs; int32_t len; int32_t cap; }; struct JanetRange { int32_t start; int32_t end; }; struct JanetRNG { uint32_t a, b, c, d; uint32_t counter; }; typedef struct JanetFile JanetFile; struct JanetFile { FILE *file; int32_t flags; }; /* For janet_try and janet_restore */ typedef struct { /* old state */ int32_t stackn; int gc_handle; JanetFiber *vm_fiber; jmp_buf *vm_jmp_buf; Janet *vm_return_reg; /* new state */ jmp_buf buf; Janet payload; int coerce_error; } JanetTryState; /***** END SECTION TYPES *****/ /***** START SECTION OPCODES *****/ /* Bytecode op argument types */ enum JanetOpArgType { JANET_OAT_SLOT, JANET_OAT_ENVIRONMENT, JANET_OAT_CONSTANT, JANET_OAT_INTEGER, JANET_OAT_TYPE, JANET_OAT_SIMPLETYPE, JANET_OAT_LABEL, JANET_OAT_FUNCDEF }; /* Various types of instructions */ enum JanetInstructionType { JINT_0, /* No args */ JINT_S, /* Slot(3) */ JINT_L, /* Label(3) */ JINT_SS, /* Slot(1), Slot(2) */ JINT_SL, /* Slot(1), Label(2) */ JINT_ST, /* Slot(1), Slot(2) */ JINT_SI, /* Slot(1), Immediate(2) */ JINT_SD, /* Slot(1), Closure(2) */ JINT_SU, /* Slot(1), Unsigned Immediate(2) */ JINT_SSS, /* Slot(1), Slot(1), Slot(1) */ JINT_SSI, /* Slot(1), Slot(1), Immediate(1) */ JINT_SSU, /* Slot(1), Slot(1), Unsigned Immediate(1) */ JINT_SES, /* Slot(1), Environment(1), Far Slot(1) */ JINT_SC /* Slot(1), Constant(2) */ }; /* All opcodes for the bytecode interpreter. */ enum JanetOpCode { JOP_NOOP, JOP_ERROR, JOP_TYPECHECK, JOP_RETURN, JOP_RETURN_NIL, JOP_ADD_IMMEDIATE, JOP_ADD, JOP_SUBTRACT_IMMEDIATE, JOP_SUBTRACT, JOP_MULTIPLY_IMMEDIATE, JOP_MULTIPLY, JOP_DIVIDE_IMMEDIATE, JOP_DIVIDE, JOP_DIVIDE_FLOOR, JOP_MODULO, JOP_REMAINDER, JOP_BAND, JOP_BOR, JOP_BXOR, JOP_BNOT, JOP_SHIFT_LEFT, JOP_SHIFT_LEFT_IMMEDIATE, JOP_SHIFT_RIGHT, JOP_SHIFT_RIGHT_IMMEDIATE, JOP_SHIFT_RIGHT_UNSIGNED, JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE, JOP_MOVE_FAR, JOP_MOVE_NEAR, JOP_JUMP, JOP_JUMP_IF, JOP_JUMP_IF_NOT, JOP_JUMP_IF_NIL, JOP_JUMP_IF_NOT_NIL, JOP_GREATER_THAN, JOP_GREATER_THAN_IMMEDIATE, JOP_LESS_THAN, JOP_LESS_THAN_IMMEDIATE, JOP_EQUALS, JOP_EQUALS_IMMEDIATE, JOP_COMPARE, JOP_LOAD_NIL, JOP_LOAD_TRUE, JOP_LOAD_FALSE, JOP_LOAD_INTEGER, JOP_LOAD_CONSTANT, JOP_LOAD_UPVALUE, JOP_LOAD_SELF, JOP_SET_UPVALUE, JOP_CLOSURE, JOP_PUSH, JOP_PUSH_2, JOP_PUSH_3, JOP_PUSH_ARRAY, JOP_CALL, JOP_TAILCALL, JOP_RESUME, JOP_SIGNAL, JOP_PROPAGATE, JOP_IN, JOP_GET, JOP_PUT, JOP_GET_INDEX, JOP_PUT_INDEX, JOP_LENGTH, JOP_MAKE_ARRAY, JOP_MAKE_BUFFER, JOP_MAKE_STRING, JOP_MAKE_STRUCT, JOP_MAKE_TABLE, JOP_MAKE_TUPLE, JOP_MAKE_BRACKET_TUPLE, JOP_GREATER_THAN_EQUAL, JOP_LESS_THAN_EQUAL, JOP_NEXT, JOP_NOT_EQUALS, JOP_NOT_EQUALS_IMMEDIATE, JOP_CANCEL, JOP_INSTRUCTION_COUNT }; /* Info about all instructions */ extern enum JanetInstructionType janet_instructions[JOP_INSTRUCTION_COUNT]; /***** END SECTION OPCODES *****/ /***** START SECTION MAIN *****/ #ifdef JANET_EV extern JANET_API const JanetAbstractType janet_stream_type; extern JANET_API const JanetAbstractType janet_channel_type; /* Run the event loop */ JANET_API void janet_loop(void); /* Run the event loop, but allow for user scheduled interrupts triggered * by janet_loop1_interrupt being called in library code, a signal handler, or * another thread. * * Example: * * while (!janet_loop_done()) { * // One turn of the event loop * JanetFiber *interrupted_fiber = janet_loop1(); * // interrupted_fiber may be NULL * // do some work here periodically... * if (NULL != interrupted_fiber) { * if (cancel_interrupted_fiber) { * janet_cancel(interrupted_fiber, janet_cstringv("fiber was interrupted for [reason]")); * } else { * janet_schedule(interrupted_fiber, janet_wrap_nil()); * } * janet_interpreter_interrupt_handled(NULL); * } * } * */ JANET_API int janet_loop_done(void); JANET_API JanetFiber *janet_loop1(void); JANET_API void janet_loop1_interrupt(JanetVM *vm); /* Wrapper around streams */ JANET_API JanetStream *janet_stream(JanetHandle handle, uint32_t flags, const JanetMethod *methods); JANET_API JanetStream *janet_stream_ext(JanetHandle handle, uint32_t flags, const JanetMethod *methods, size_t size); /* Allow for type punning streams */ JANET_API void janet_stream_close(JanetStream *stream); JANET_API Janet janet_cfun_stream_close(int32_t argc, Janet *argv); JANET_API Janet janet_cfun_stream_read(int32_t argc, Janet *argv); JANET_API Janet janet_cfun_stream_chunk(int32_t argc, Janet *argv); JANET_API Janet janet_cfun_stream_write(int32_t argc, Janet *argv); JANET_API void janet_stream_flags(JanetStream *stream, uint32_t flags); /* Queue a fiber to run on the event loop */ JANET_API void janet_schedule(JanetFiber *fiber, Janet value); JANET_API void janet_cancel(JanetFiber *fiber, Janet value); JANET_API void janet_schedule_signal(JanetFiber *fiber, Janet value, JanetSignal sig); JANET_API void janet_schedule_soon(JanetFiber *fiber, Janet value, JanetSignal sig); /* Shorthand for yielding to event loop in C */ JANET_NO_RETURN JANET_API void janet_await(void); JANET_NO_RETURN JANET_API void janet_sleep_await(double sec); /* For use inside listeners - adds a timeout to the current fiber, such that * it will be resumed after sec seconds if no other event schedules the current fiber. */ JANET_API void janet_addtimeout(double sec); JANET_API void janet_addtimeout_nil(double sec); JANET_API void janet_ev_inc_refcount(void); JANET_API void janet_ev_dec_refcount(void); /* Thread aware abstract types and helpers */ JANET_API void *janet_abstract_begin_threaded(const JanetAbstractType *atype, size_t size); JANET_API void *janet_abstract_end_threaded(void *x); JANET_API void *janet_abstract_threaded(const JanetAbstractType *atype, size_t size); /* Allow reference counting on threaded abstract types. This is useful when external code , either * in the current OS thread or in a different OS thread, takes a pointer to this abstract type. The programmer * should tncrement the reference count when taking the pointer, and then decrement and possibly cleanup and free * if the reference count is 0. */ JANET_API int32_t janet_abstract_incref(void *abst); JANET_API int32_t janet_abstract_decref(void *abst); /* If this returns 0, *abst will be deinitialized and freed. Useful shorthand if there is no other cleanup for * this abstract type before calling `janet_free` on it's backing memory. */ JANET_API int32_t janet_abstract_decref_maybe_free(void *abst); /* Expose channel utilities */ JANET_API JanetChannel *janet_channel_make(uint32_t limit); JANET_API JanetChannel *janet_channel_make_threaded(uint32_t limit); JANET_API JanetChannel *janet_getchannel(const Janet *argv, int32_t n); JANET_API JanetChannel *janet_optchannel(const Janet *argv, int32_t argc, int32_t n, JanetChannel *dflt); JANET_API int janet_channel_give(JanetChannel *channel, Janet x); JANET_API int janet_channel_take(JanetChannel *channel, Janet *out); /* Expose some OS sync primitives - mutexes and reader-writer locks */ JANET_API size_t janet_os_mutex_size(void); JANET_API size_t janet_os_rwlock_size(void); JANET_API void janet_os_mutex_init(JanetOSMutex *mutex); JANET_API void janet_os_mutex_deinit(JanetOSMutex *mutex); JANET_API void janet_os_mutex_lock(JanetOSMutex *mutex); JANET_API void janet_os_mutex_unlock(JanetOSMutex *mutex); JANET_API void janet_os_rwlock_init(JanetOSRWLock *rwlock); JANET_API void janet_os_rwlock_deinit(JanetOSRWLock *rwlock); JANET_API void janet_os_rwlock_rlock(JanetOSRWLock *rwlock); JANET_API void janet_os_rwlock_wlock(JanetOSRWLock *rwlock); JANET_API void janet_os_rwlock_runlock(JanetOSRWLock *rwlock); JANET_API void janet_os_rwlock_wunlock(JanetOSRWLock *rwlock); /* Get last error from an IO operation */ JANET_API Janet janet_ev_lasterr(void); /* Async service for calling a function or syscall in a background thread. This is not * as efficient in the slightest as using Streams but can be used for arbitrary blocking * functions and syscalls. */ /* Used to pass data between the main thread and worker threads for simple tasks. * We could just use a pointer but this prevents malloc/free in the common case * of only a handful of arguments. */ typedef struct { int tag; int argi; void *argp; Janet argj; JanetFiber *fiber; } JanetEVGenericMessage; /* How to resume or cancel after a threaded call. Not exhaustive of the possible * ways one might want to resume after returning from a threaded call, but should * cover most of the common cases. For something more complicated, such as resuming * with an abstract type or a struct, one should use janet_ev_threaded_call instead * of janet_ev_threaded_await with a custom callback. */ #define JANET_EV_TCTAG_NIL 0 /* resume with nil */ #define JANET_EV_TCTAG_INTEGER 1 /* resume with janet_wrap_integer(argi) */ #define JANET_EV_TCTAG_STRING 2 /* resume with janet_cstringv((const char *) argp) */ #define JANET_EV_TCTAG_STRINGF 3 /* resume with janet_cstringv((const char *) argp), then call free on argp. */ #define JANET_EV_TCTAG_KEYWORD 4 /* resume with janet_ckeywordv((const char *) argp) */ #define JANET_EV_TCTAG_ERR_STRING 5 /* cancel with janet_cstringv((const char *) argp) */ #define JANET_EV_TCTAG_ERR_STRINGF 6 /* cancel with janet_cstringv((const char *) argp), then call free on argp. */ #define JANET_EV_TCTAG_ERR_KEYWORD 7 /* cancel with janet_ckeywordv((const char *) argp) */ #define JANET_EV_TCTAG_BOOLEAN 8 /* resume with janet_wrap_boolean(argi) */ /* Function pointer that is run in the thread pool */ typedef JanetEVGenericMessage(*JanetThreadedSubroutine)(JanetEVGenericMessage arguments); /* Handler for events posted to the event loop */ typedef void (*JanetCallback)(JanetEVGenericMessage return_value); /* Handler that is run in the main thread with the result of the JanetAsyncSubroutine (same as JanetCallback) */ typedef void (*JanetThreadedCallback)(JanetEVGenericMessage return_value); /* API calls for quickly offloading some work in C to a new thread or thread pool. */ JANET_API void janet_ev_threaded_call(JanetThreadedSubroutine fp, JanetEVGenericMessage arguments, JanetThreadedCallback cb); JANET_NO_RETURN JANET_API void janet_ev_threaded_await(JanetThreadedSubroutine fp, int tag, int argi, void *argp); /* Post callback + userdata to an event loop. Takes the vm parameter to allow posting from other * threads or signal handlers. Use NULL to post to the current thread. */ JANET_API void janet_ev_post_event(JanetVM *vm, JanetCallback cb, JanetEVGenericMessage msg); /* Callback used by janet_ev_threaded_await */ JANET_API void janet_ev_default_threaded_callback(JanetEVGenericMessage return_value); /* Read async from a stream. These function yield to the event-loop with janet_await(), and so do not return. * When the fiber is resumed, the fiber will simply continue to the next Janet abstract machine instruction. */ JANET_NO_RETURN JANET_API void janet_ev_read(JanetStream *stream, JanetBuffer *buf, int32_t nbytes); JANET_NO_RETURN JANET_API void janet_ev_readchunk(JanetStream *stream, JanetBuffer *buf, int32_t nbytes); #ifdef JANET_NET JANET_NO_RETURN JANET_API void janet_ev_recv(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int flags); JANET_NO_RETURN JANET_API void janet_ev_recvchunk(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int flags); JANET_NO_RETURN JANET_API void janet_ev_recvfrom(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int flags); #endif /* Write async to a stream. These function yield to the event-loop with janet_await(), and so do not return. * When the fiber is resumed, the fiber will simply continue to the next Janet abstract machine instruction. */ JANET_NO_RETURN JANET_API void janet_ev_write_buffer(JanetStream *stream, JanetBuffer *buf); JANET_NO_RETURN JANET_API void janet_ev_write_string(JanetStream *stream, JanetString str); #ifdef JANET_NET JANET_NO_RETURN JANET_API void janet_ev_send_buffer(JanetStream *stream, JanetBuffer *buf, int flags); JANET_NO_RETURN JANET_API void janet_ev_send_string(JanetStream *stream, JanetString str, int flags); JANET_NO_RETURN JANET_API void janet_ev_sendto_buffer(JanetStream *stream, JanetBuffer *buf, void *dest, int flags); JANET_NO_RETURN JANET_API void janet_ev_sendto_string(JanetStream *stream, JanetString str, void *dest, int flags); #endif #endif /* Parsing. * * E.g. * * JanetParser parser; * janet_parser_init(&parser); * for (int i = 0; i < source_code_length + 1; i++) { * if (i >= source_code_length) { * janet_parser_eof(&parser); * } else { * janet_parser_consume(&parser, source_code[i]); * } * while (janet_parser_has_more(&parser)) { * Janet x = janet_parser_produce(&parser); * janet_printf("got value: %v\n", x); * } * switch (janet_parser_status(&parser)) { * case JANET_PARSE_PENDING: break; * case JANET_PARSE_ERROR: janet_eprintf("error: %s\n", janet_parser_error(&parser)); break; * case JANET_PARSE_ROOT: break; * case JANET_PARSE_DEAD: break; * } * } * janet_parser_deinit(&parser); * * */ extern JANET_API const JanetAbstractType janet_parser_type; /* Construct/destruct a parser. Parsers can be allocated on the stack or the heap. */ JANET_API void janet_parser_init(JanetParser *parser); JANET_API void janet_parser_deinit(JanetParser *parser); /* Feed bytes into the parser. Check the parser state after every byte to handle errors. */ JANET_API void janet_parser_consume(JanetParser *parser, uint8_t c); /* Check the current status of the parser */ JANET_API enum JanetParserStatus janet_parser_status(JanetParser *parser); /* Produce a value from the parser. Call this when janet_parser_has_more(&parser) is non-zero. */ JANET_API Janet janet_parser_produce(JanetParser *parser); /* Produce a value from the parser, wrapped in a tuple. The tuple is used to carry the source mapping information of the * top level form, such as a line number or symbol. */ JANET_API Janet janet_parser_produce_wrapped(JanetParser *parser); /* When there is an error while parsing (janet_parser_status(&parser) == JANET_PARSE_ERROR), get a nice error string. * Calling this will also flush the parser. */ JANET_API const char *janet_parser_error(JanetParser *parser); /* If there is a parsing error, flush the parser to set the state back to empty. * This allows for better error recover and less confusing error messages on bad syntax deep inside nested data structures. */ JANET_API void janet_parser_flush(JanetParser *parser); /* Indicate that there is no more source code */ JANET_API void janet_parser_eof(JanetParser *parser); /* If non-zero, the parser has values ready to be produced. */ JANET_API int janet_parser_has_more(JanetParser *parser); /* Assembly */ #ifdef JANET_ASSEMBLER typedef struct JanetAssembleResult JanetAssembleResult; enum JanetAssembleStatus { JANET_ASSEMBLE_OK, JANET_ASSEMBLE_ERROR }; struct JanetAssembleResult { JanetFuncDef *funcdef; JanetString error; enum JanetAssembleStatus status; }; JANET_API JanetAssembleResult janet_asm(Janet source, int flags); JANET_API Janet janet_disasm(JanetFuncDef *def); JANET_API Janet janet_asm_decode_instruction(uint32_t instr); #endif /* Compilation */ typedef struct JanetCompileResult JanetCompileResult; enum JanetCompileStatus { JANET_COMPILE_OK, JANET_COMPILE_ERROR }; struct JanetCompileResult { JanetFuncDef *funcdef; JanetString error; JanetFiber *macrofiber; JanetSourceMapping error_mapping; enum JanetCompileStatus status; }; JANET_API JanetCompileResult janet_compile(Janet source, JanetTable *env, JanetString where); JANET_API JanetCompileResult janet_compile_lint( Janet source, JanetTable *env, JanetString where, JanetArray *lints); /* Get the default environment for janet */ JANET_API JanetTable *janet_core_env(JanetTable *replacements); JANET_API JanetTable *janet_core_lookup_table(JanetTable *replacements); /* Execute strings. * * These functions wrap parsing, compilation, and evalutation into convenient functions. * */ #define JANET_DO_ERROR_RUNTIME 0x01 #define JANET_DO_ERROR_COMPILE 0x02 #define JANET_DO_ERROR_PARSE 0x04 JANET_API int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char *sourcePath, Janet *out); JANET_API int janet_dostring(JanetTable *env, const char *str, const char *sourcePath, Janet *out); /* Run the entrypoint of a wrapped program */ JANET_API int janet_loop_fiber(JanetFiber *fiber); /* Number scanning */ JANET_API int janet_scan_number(const uint8_t *str, int32_t len, double *out); JANET_API int janet_scan_number_base(const uint8_t *str, int32_t len, int32_t base, double *out); JANET_API int janet_scan_int64(const uint8_t *str, int32_t len, int64_t *out); JANET_API int janet_scan_uint64(const uint8_t *str, int32_t len, uint64_t *out); #ifdef JANET_INT_TYPES JANET_API int janet_scan_numeric(const uint8_t *str, int32_t len, Janet *out); #endif /* Debugging */ JANET_API void janet_debug_break(JanetFuncDef *def, int32_t pc); JANET_API void janet_debug_unbreak(JanetFuncDef *def, int32_t pc); JANET_API void janet_debug_find( JanetFuncDef **def_out, int32_t *pc_out, JanetString source, int32_t line, int32_t column); /* RNG */ extern JANET_API const JanetAbstractType janet_rng_type; JANET_API JanetRNG *janet_default_rng(void); JANET_API void janet_rng_seed(JanetRNG *rng, uint32_t seed); JANET_API void janet_rng_longseed(JanetRNG *rng, const uint8_t *bytes, int32_t len); JANET_API uint32_t janet_rng_u32(JanetRNG *rng); JANET_API double janet_rng_double(JanetRNG *rng); /* Array functions */ JANET_API JanetArray *janet_array(int32_t capacity); JANET_API JanetArray *janet_array_weak(int32_t capacity); JANET_API JanetArray *janet_array_n(const Janet *elements, int32_t n); JANET_API void janet_array_ensure(JanetArray *array, int32_t capacity, int32_t growth); JANET_API void janet_array_setcount(JanetArray *array, int32_t count); JANET_API void janet_array_push(JanetArray *array, Janet x); JANET_API Janet janet_array_pop(JanetArray *array); JANET_API Janet janet_array_peek(JanetArray *array); /* Buffer functions */ #define JANET_BUFFER_FLAG_NO_REALLOC 0x10000 JANET_API JanetBuffer *janet_buffer(int32_t capacity); JANET_API JanetBuffer *janet_buffer_init(JanetBuffer *buffer, int32_t capacity); JANET_API JanetBuffer *janet_pointer_buffer_unsafe(void *memory, int32_t capacity, int32_t count); JANET_API void janet_buffer_deinit(JanetBuffer *buffer); JANET_API void janet_buffer_ensure(JanetBuffer *buffer, int32_t capacity, int32_t growth); JANET_API void janet_buffer_setcount(JanetBuffer *buffer, int32_t count); JANET_API void janet_buffer_extra(JanetBuffer *buffer, int32_t n); JANET_API void janet_buffer_push_bytes(JanetBuffer *buffer, const uint8_t *string, int32_t len); JANET_API void janet_buffer_push_string(JanetBuffer *buffer, JanetString string); JANET_API void janet_buffer_push_cstring(JanetBuffer *buffer, const char *cstring); JANET_API void janet_buffer_push_u8(JanetBuffer *buffer, uint8_t x); JANET_API void janet_buffer_push_u16(JanetBuffer *buffer, uint16_t x); JANET_API void janet_buffer_push_u32(JanetBuffer *buffer, uint32_t x); JANET_API void janet_buffer_push_u64(JanetBuffer *buffer, uint64_t x); /* Tuple */ #define JANET_TUPLE_FLAG_BRACKETCTOR 0x10000 #define janet_tuple_head(t) ((JanetTupleHead *)((char *)t - offsetof(JanetTupleHead, data))) #define janet_tuple_from_head(gcobject) ((JanetTuple)((char *)gcobject + offsetof(JanetTupleHead, data))) #define janet_tuple_length(t) (janet_tuple_head(t)->length) #define janet_tuple_hash(t) (janet_tuple_head(t)->hash) #define janet_tuple_sm_line(t) (janet_tuple_head(t)->sm_line) #define janet_tuple_sm_column(t) (janet_tuple_head(t)->sm_column) #define janet_tuple_flag(t) (janet_tuple_head(t)->gc.flags) JANET_API Janet *janet_tuple_begin(int32_t length); JANET_API JanetTuple janet_tuple_end(Janet *tuple); JANET_API JanetTuple janet_tuple_n(const Janet *values, int32_t n); /* String/Symbol functions */ #define janet_string_head(s) ((JanetStringHead *)((char *)s - offsetof(JanetStringHead, data))) #define janet_string_length(s) (janet_string_head(s)->length) #define janet_string_hash(s) (janet_string_head(s)->hash) JANET_API uint8_t *janet_string_begin(int32_t length); JANET_API JanetString janet_string_end(uint8_t *str); JANET_API JanetString janet_string(const uint8_t *buf, int32_t len); JANET_API JanetString janet_cstring(const char *cstring); JANET_API int janet_string_compare(JanetString lhs, JanetString rhs); JANET_API int janet_string_equal(JanetString lhs, JanetString rhs); JANET_API int janet_string_equalconst(JanetString lhs, const uint8_t *rhs, int32_t rlen, int32_t rhash); JANET_API JanetString janet_description(Janet x); JANET_API JanetString janet_to_string(Janet x); JANET_API void janet_to_string_b(JanetBuffer *buffer, Janet x); JANET_API void janet_description_b(JanetBuffer *buffer, Janet x); #define janet_cstringv(cstr) janet_wrap_string(janet_cstring(cstr)) #define janet_stringv(str, len) janet_wrap_string(janet_string((str), (len))) JANET_API JanetString janet_formatc(const char *format, ...); JANET_API JanetBuffer *janet_formatb(JanetBuffer *bufp, const char *format, ...); JANET_API void janet_formatbv(JanetBuffer *bufp, const char *format, va_list args); /* Symbol functions */ JANET_API JanetSymbol janet_symbol(const uint8_t *str, int32_t len); JANET_API JanetSymbol janet_csymbol(const char *str); JANET_API JanetSymbol janet_symbol_gen(void); #define janet_symbolv(str, len) janet_wrap_symbol(janet_symbol((str), (len))) #define janet_csymbolv(cstr) janet_wrap_symbol(janet_csymbol(cstr)) /* Keyword functions */ #define janet_keyword janet_symbol #define janet_ckeyword janet_csymbol #define janet_keywordv(str, len) janet_wrap_keyword(janet_keyword((str), (len))) #define janet_ckeywordv(cstr) janet_wrap_keyword(janet_ckeyword(cstr)) /* Structs */ #define janet_struct_head(t) ((JanetStructHead *)((char *)t - offsetof(JanetStructHead, data))) #define janet_struct_from_head(t) ((JanetStruct)((char *)gcobject + offsetof(JanetStructHead, data))) #define janet_struct_length(t) (janet_struct_head(t)->length) #define janet_struct_capacity(t) (janet_struct_head(t)->capacity) #define janet_struct_hash(t) (janet_struct_head(t)->hash) #define janet_struct_proto(t) (janet_struct_head(t)->proto) JANET_API JanetKV *janet_struct_begin(int32_t count); JANET_API void janet_struct_put(JanetKV *st, Janet key, Janet value); JANET_API JanetStruct janet_struct_end(JanetKV *st); JANET_API Janet janet_struct_get(JanetStruct st, Janet key); JANET_API Janet janet_struct_rawget(JanetStruct st, Janet key); JANET_API Janet janet_struct_get_ex(JanetStruct st, Janet key, JanetStruct *which); JANET_API JanetTable *janet_struct_to_table(JanetStruct st); JANET_API const JanetKV *janet_struct_find(JanetStruct st, Janet key); /* Table functions */ JANET_API JanetTable *janet_table(int32_t capacity); JANET_API JanetTable *janet_table_init(JanetTable *table, int32_t capacity); JANET_API JanetTable *janet_table_init_raw(JanetTable *table, int32_t capacity); JANET_API void janet_table_deinit(JanetTable *table); JANET_API Janet janet_table_get(JanetTable *t, Janet key); JANET_API Janet janet_table_get_ex(JanetTable *t, Janet key, JanetTable **which); JANET_API Janet janet_table_rawget(JanetTable *t, Janet key); JANET_API Janet janet_table_remove(JanetTable *t, Janet key); JANET_API void janet_table_put(JanetTable *t, Janet key, Janet value); JANET_API JanetStruct janet_table_to_struct(JanetTable *t); JANET_API void janet_table_merge_table(JanetTable *table, JanetTable *other); JANET_API void janet_table_merge_struct(JanetTable *table, JanetStruct other); JANET_API JanetKV *janet_table_find(JanetTable *t, Janet key); JANET_API JanetTable *janet_table_clone(JanetTable *table); JANET_API void janet_table_clear(JanetTable *table); JANET_API JanetTable *janet_table_weakk(int32_t capacity); JANET_API JanetTable *janet_table_weakv(int32_t capacity); JANET_API JanetTable *janet_table_weakkv(int32_t capacity); /* Fiber */ JANET_API JanetFiber *janet_fiber(JanetFunction *callee, int32_t capacity, int32_t argc, const Janet *argv); JANET_API JanetFiber *janet_fiber_reset(JanetFiber *fiber, JanetFunction *callee, int32_t argc, const Janet *argv); JANET_API JanetFiberStatus janet_fiber_status(JanetFiber *fiber); JANET_API int janet_fiber_can_resume(JanetFiber *fiber); JANET_API JanetFiber *janet_current_fiber(void); JANET_API JanetFiber *janet_root_fiber(void); /* Treat similar types through uniform interfaces for iteration */ JANET_API int janet_indexed_view(Janet seq, const Janet **data, int32_t *len); JANET_API int janet_bytes_view(Janet str, const uint8_t **data, int32_t *len); JANET_API int janet_dictionary_view(Janet tab, const JanetKV **data, int32_t *len, int32_t *cap); JANET_API Janet janet_dictionary_get(const JanetKV *data, int32_t cap, Janet key); JANET_API const JanetKV *janet_dictionary_next(const JanetKV *kvs, int32_t cap, const JanetKV *kv); /* Abstract */ #define janet_abstract_head(u) ((JanetAbstractHead *)((char *)u - offsetof(JanetAbstractHead, data))) #define janet_abstract_from_head(gcobject) ((JanetAbstract)((char *)gcobject + offsetof(JanetAbstractHead, data))) #define janet_abstract_type(u) (janet_abstract_head(u)->type) #define janet_abstract_size(u) (janet_abstract_head(u)->size) JANET_API void *janet_abstract_begin(const JanetAbstractType *type, size_t size); JANET_API JanetAbstract janet_abstract_end(void *abstractTemplate); JANET_API JanetAbstract janet_abstract(const JanetAbstractType *type, size_t size); /* begin and end in one call */ /* Native */ typedef void (*JanetModule)(JanetTable *); typedef JanetBuildConfig(*JanetModconf)(void); JANET_API JanetModule janet_native(const char *name, JanetString *error); /* Marshaling */ #define JANET_MARSHAL_UNSAFE 0x20000 #define JANET_MARSHAL_NO_CYCLES 0x40000 JANET_API void janet_marshal( JanetBuffer *buf, Janet x, JanetTable *rreg, int flags); JANET_API Janet janet_unmarshal( const uint8_t *bytes, size_t len, int flags, JanetTable *reg, const uint8_t **next); JANET_API JanetTable *janet_env_lookup(JanetTable *env); JANET_API void janet_env_lookup_into(JanetTable *renv, JanetTable *env, const char *prefix, int recurse); /* GC */ /* The main interface to garbage collection. Call this to do a full mark and sweep cleanup. */ JANET_API void janet_collect(void); /* Add "roots" to the garbage collector to prevent the runtime from freeing objects. * This is only needed if code outside of Janet keeps references to Janet values */ JANET_API void janet_gcroot(Janet root); JANET_API int janet_gcunroot(Janet root); /* Allow disabling garbage collection temporarily or for certain sections of code. * this is a very cheap operation. */ JANET_API int janet_gclock(void); JANET_API void janet_gcunlock(int handle); /* The mark and sweep components of the mark and sweep collector. Prefer using janet_collect directly. */ JANET_API void janet_mark(Janet x); JANET_API void janet_sweep(void); /* Clear all gced memory and call all destructors. Used as part of the standard cleanup routune, most programmers will not need this. */ JANET_API void janet_clear_memory(void); /* Remove all GC roots. Used as part of the standard cleanup routine, most programmers will not need this. */ JANET_API int janet_gcunrootall(Janet root); /* Hint to the collector that memory of size s was just allocated to help it better understand when to free memory. */ JANET_API void janet_gcpressure(size_t s); /* Functions */ JANET_API JanetFuncDef *janet_funcdef_alloc(void); JANET_API JanetFunction *janet_thunk(JanetFuncDef *def); /* Get a function that when called with no args, will return x. */ JANET_API JanetFunction *janet_thunk_delay(Janet x); /* Do some simple verfification on constructed bytecode to disallow any trivial incorrect bytecode. */ JANET_API int janet_verify(JanetFuncDef *def); /* Pretty printing */ #define JANET_PRETTY_COLOR 1 #define JANET_PRETTY_ONELINE 2 #define JANET_PRETTY_NOTRUNC 4 JANET_API JanetBuffer *janet_pretty(JanetBuffer *buffer, int depth, int flags, Janet x); /* Misc */ #ifdef JANET_PRF #define JANET_HASH_KEY_SIZE 16 JANET_API void janet_init_hash_key(uint8_t key[JANET_HASH_KEY_SIZE]); #endif JANET_API void janet_try_init(JanetTryState *state); #if defined(JANET_BSD) || defined(JANET_APPLE) #define janet_try(state) (janet_try_init(state), (JanetSignal) _setjmp((state)->buf)) #else #define janet_try(state) (janet_try_init(state), (JanetSignal) setjmp((state)->buf)) #endif JANET_API void janet_restore(JanetTryState *state); JANET_API int janet_equals(Janet x, Janet y); JANET_API int32_t janet_hash(Janet x); JANET_API int janet_compare(Janet x, Janet y); JANET_API int janet_cstrcmp(JanetString str, const char *other); JANET_API Janet janet_in(Janet ds, Janet key); JANET_API Janet janet_get(Janet ds, Janet key); JANET_API Janet janet_next(Janet ds, Janet key); JANET_API Janet janet_getindex(Janet ds, int32_t index); JANET_API int32_t janet_length(Janet x); JANET_API Janet janet_lengthv(Janet x); JANET_API void janet_put(Janet ds, Janet key, Janet value); JANET_API void janet_putindex(Janet ds, int32_t index, Janet value); #define janet_flag_at(F, I) ((F) & ((1ULL) << (I))) JANET_API Janet janet_wrap_number_safe(double x); JANET_API int janet_keyeq(Janet x, const char *cstring); JANET_API int janet_streq(Janet x, const char *cstring); JANET_API int janet_symeq(Janet x, const char *cstring); JANET_API int32_t janet_sorted_keys(const JanetKV *dict, int32_t cap, int32_t *index_buffer); /* VM functions */ JANET_API int janet_init(void); JANET_API void janet_deinit(void); JANET_API JanetVM *janet_vm_alloc(void); JANET_API JanetVM *janet_local_vm(void); JANET_API void janet_vm_free(JanetVM *vm); JANET_API void janet_vm_save(JanetVM *into); JANET_API void janet_vm_load(JanetVM *from); JANET_API void janet_interpreter_interrupt(JanetVM *vm); JANET_API void janet_interpreter_interrupt_handled(JanetVM *vm); /* Call this after running interrupt handler */ JANET_API JanetSignal janet_continue(JanetFiber *fiber, Janet in, Janet *out); JANET_API JanetSignal janet_continue_signal(JanetFiber *fiber, Janet in, Janet *out, JanetSignal sig); JANET_API JanetSignal janet_pcall(JanetFunction *fun, int32_t argn, const Janet *argv, Janet *out, JanetFiber **f); JANET_API JanetSignal janet_step(JanetFiber *fiber, Janet in, Janet *out); JANET_API Janet janet_call(JanetFunction *fun, int32_t argc, const Janet *argv); JANET_API Janet janet_mcall(const char *name, int32_t argc, Janet *argv); JANET_API void janet_stacktrace(JanetFiber *fiber, Janet err); JANET_API void janet_stacktrace_ext(JanetFiber *fiber, Janet err, const char *prefix); /* Sandboxing API */ #define JANET_SANDBOX_SANDBOX 1 #define JANET_SANDBOX_SUBPROCESS 2 #define JANET_SANDBOX_NET_CONNECT 4 #define JANET_SANDBOX_NET_LISTEN 8 #define JANET_SANDBOX_FFI_DEFINE 16 #define JANET_SANDBOX_FS_WRITE 32 #define JANET_SANDBOX_FS_READ 64 #define JANET_SANDBOX_HRTIME 128 #define JANET_SANDBOX_ENV 256 #define JANET_SANDBOX_DYNAMIC_MODULES 512 #define JANET_SANDBOX_FS_TEMP 1024 #define JANET_SANDBOX_FFI_USE 2048 #define JANET_SANDBOX_FFI_JIT 4096 #define JANET_SANDBOX_SIGNAL 8192 #define JANET_SANDBOX_CHROOT 16384 #define JANET_SANDBOX_FFI (JANET_SANDBOX_FFI_DEFINE | JANET_SANDBOX_FFI_USE | JANET_SANDBOX_FFI_JIT) #define JANET_SANDBOX_FS (JANET_SANDBOX_FS_WRITE | JANET_SANDBOX_FS_READ | JANET_SANDBOX_FS_TEMP) #define JANET_SANDBOX_NET (JANET_SANDBOX_NET_CONNECT | JANET_SANDBOX_NET_LISTEN) #define JANET_SANDBOX_COMPILE 32768 #define JANET_SANDBOX_ASM 65536 #define JANET_SANDBOX_THREADS 131072 #define JANET_SANDBOX_UNMARSHAL 262144 #define JANET_SANDBOX_ALL (UINT32_MAX) JANET_API void janet_sandbox(uint32_t flags); JANET_API void janet_sandbox_assert(uint32_t forbidden_flags); /* Scratch Memory API */ typedef void (*JanetScratchFinalizer)(void *); JANET_API void *janet_smalloc(size_t size); JANET_API void *janet_srealloc(void *mem, size_t size); JANET_API void *janet_scalloc(size_t nmemb, size_t size); JANET_API void janet_sfinalizer(void *mem, JanetScratchFinalizer finalizer); JANET_API void janet_sfree(void *mem); /* C Library helpers */ typedef enum { JANET_BINDING_NONE, JANET_BINDING_DEF, JANET_BINDING_VAR, JANET_BINDING_MACRO, JANET_BINDING_DYNAMIC_DEF, JANET_BINDING_DYNAMIC_MACRO } JanetBindingType; typedef struct { JanetBindingType type; Janet value; enum { JANET_BINDING_DEP_NONE, JANET_BINDING_DEP_RELAXED, JANET_BINDING_DEP_NORMAL, JANET_BINDING_DEP_STRICT, } deprecation; } JanetBinding; JANET_API void janet_def(JanetTable *env, const char *name, Janet val, const char *documentation); JANET_API void janet_var(JanetTable *env, const char *name, Janet val, const char *documentation); JANET_API void janet_cfuns(JanetTable *env, const char *regprefix, const JanetReg *cfuns); JANET_API void janet_cfuns_prefix(JanetTable *env, const char *regprefix, const JanetReg *cfuns); JANET_API JanetBindingType janet_resolve(JanetTable *env, JanetSymbol sym, Janet *out); JANET_API JanetBinding janet_resolve_ext(JanetTable *env, JanetSymbol sym); /* Get values from the core environment. */ JANET_API Janet janet_resolve_core(const char *name); /* New C API * * The "New" C API is intended to make constructing good documentation and source maps * much more straightforward. This not only ensures doc strings for functions in native * modules, it also add source code mapping for C functions so that programmers can see which * file and line a native function that calls janet_panic came from. * * */ /* Shorthand for janet C function declarations */ #define JANET_CFUN(name) Janet name (int32_t argc, Janet *argv) /* Declare a C function with documentation and source mapping */ #define JANET_REG_END {NULL, NULL, NULL, NULL, 0} /* no docstrings or sourcemaps */ #define JANET_REG_(JNAME, CNAME) {JNAME, CNAME, NULL, NULL, 0} #define JANET_FN_(CNAME, USAGE, DOCSTRING) \ Janet CNAME (int32_t argc, Janet *argv) #define JANET_DEF_(ENV, JNAME, VAL, DOC) \ janet_def(ENV, JNAME, VAL, NULL) /* sourcemaps only */ #define JANET_REG_S(JNAME, CNAME) {JNAME, CNAME, NULL, __FILE__, CNAME##_sourceline_} #define JANET_FN_S(CNAME, USAGE, DOCSTRING) \ static const int32_t CNAME##_sourceline_ = __LINE__; \ Janet CNAME (int32_t argc, Janet *argv) #define JANET_DEF_S(ENV, JNAME, VAL, DOC) \ janet_def_sm(ENV, JNAME, VAL, NULL, __FILE__, __LINE__) /* docstring only */ #define JANET_REG_D(JNAME, CNAME) {JNAME, CNAME, CNAME##_docstring_, NULL, 0} #define JANET_FN_D(CNAME, USAGE, DOCSTRING) \ static const char CNAME##_docstring_[] = USAGE "\n\n" DOCSTRING; \ Janet CNAME (int32_t argc, Janet *argv) #define JANET_DEF_D(ENV, JNAME, VAL, DOC) \ janet_def(ENV, JNAME, VAL, DOC) /* sourcemaps and docstrings */ #define JANET_REG_SD(JNAME, CNAME) {JNAME, CNAME, CNAME##_docstring_, __FILE__, CNAME##_sourceline_} #define JANET_FN_SD(CNAME, USAGE, DOCSTRING) \ static const int32_t CNAME##_sourceline_ = __LINE__; \ static const char CNAME##_docstring_[] = USAGE "\n\n" DOCSTRING; \ Janet CNAME (int32_t argc, Janet *argv) #define JANET_DEF_SD(ENV, JNAME, VAL, DOC) \ janet_def_sm(ENV, JNAME, VAL, DOC, __FILE__, __LINE__) /* Choose defaults for source mapping and docstring based on config defs */ #if defined(JANET_NO_SOURCEMAPS) && defined(JANET_NO_DOCSTRINGS) #define JANET_REG JANET_REG_ #define JANET_FN JANET_FN_ #define JANET_DEF JANET_DEF_ #elif defined(JANET_NO_SOURCEMAPS) && !defined(JANET_NO_DOCSTRINGS) #define JANET_REG JANET_REG_D #define JANET_FN JANET_FN_D #define JANET_DEF JANET_DEF_D #elif !defined(JANET_NO_SOURCEMAPS) && defined(JANET_NO_DOCSTRINGS) #define JANET_REG JANET_REG_S #define JANET_FN JANET_FN_S #define JANET_DEF JANET_DEF_S #elif !defined(JANET_NO_SOURCEMAPS) && !defined(JANET_NO_DOCSTRINGS) #define JANET_REG JANET_REG_SD #define JANET_FN JANET_FN_SD #define JANET_DEF JANET_DEF_SD #endif /* Define things with source mapping information */ JANET_API void janet_cfuns_ext(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns); JANET_API void janet_cfuns_ext_prefix(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns); JANET_API void janet_def_sm(JanetTable *env, const char *name, Janet val, const char *documentation, const char *source_file, int32_t source_line); JANET_API void janet_var_sm(JanetTable *env, const char *name, Janet val, const char *documentation, const char *source_file, int32_t source_line); /* Legacy definition of C functions */ JANET_API void janet_register(const char *name, JanetCFunction cfun); /* Allow setting entry name for static libraries */ #ifdef __cplusplus #define JANET_MODULE_PREFIX extern "C" #else #define JANET_MODULE_PREFIX #endif #ifndef JANET_ENTRY_NAME #define JANET_MODULE_ENTRY \ JANET_MODULE_PREFIX JANET_EXPORT JanetBuildConfig _janet_mod_config(void) { \ return janet_config_current(); \ } \ JANET_MODULE_PREFIX JANET_EXPORT void _janet_init #else #define JANET_MODULE_ENTRY JANET_MODULE_PREFIX JANET_API void JANET_ENTRY_NAME #endif JANET_NO_RETURN JANET_API void janet_signalv(JanetSignal signal, Janet message); JANET_NO_RETURN JANET_API void janet_panicv(Janet message); JANET_NO_RETURN JANET_API void janet_panic(const char *message); JANET_NO_RETURN JANET_API void janet_panics(JanetString message); JANET_NO_RETURN JANET_API void janet_panicf(const char *format, ...); JANET_API void janet_dynprintf(const char *name, FILE *dflt_file, const char *format, ...); #define janet_printf(...) janet_dynprintf("out", stdout, __VA_ARGS__) #define janet_eprintf(...) janet_dynprintf("err", stderr, __VA_ARGS__) JANET_NO_RETURN JANET_API void janet_panic_type(Janet x, int32_t n, int expected); JANET_NO_RETURN JANET_API void janet_panic_abstract(Janet x, int32_t n, const JanetAbstractType *at); JANET_API void janet_arity(int32_t arity, int32_t min, int32_t max); JANET_API void janet_fixarity(int32_t arity, int32_t fix); JANET_API int janet_getmethod(JanetKeyword method, const JanetMethod *methods, Janet *out); JANET_API Janet janet_nextmethod(const JanetMethod *methods, Janet key); JANET_API double janet_getnumber(const Janet *argv, int32_t n); JANET_API JanetArray *janet_getarray(const Janet *argv, int32_t n); JANET_API JanetTuple janet_gettuple(const Janet *argv, int32_t n); JANET_API JanetTable *janet_gettable(const Janet *argv, int32_t n); JANET_API JanetStruct janet_getstruct(const Janet *argv, int32_t n); JANET_API JanetString janet_getstring(const Janet *argv, int32_t n); JANET_API const char *janet_getcstring(const Janet *argv, int32_t n); JANET_API const char *janet_getcbytes(const Janet *argv, int32_t n); JANET_API JanetSymbol janet_getsymbol(const Janet *argv, int32_t n); JANET_API JanetKeyword janet_getkeyword(const Janet *argv, int32_t n); JANET_API JanetBuffer *janet_getbuffer(const Janet *argv, int32_t n); JANET_API JanetFiber *janet_getfiber(const Janet *argv, int32_t n); JANET_API JanetFunction *janet_getfunction(const Janet *argv, int32_t n); JANET_API JanetCFunction janet_getcfunction(const Janet *argv, int32_t n); JANET_API int janet_getboolean(const Janet *argv, int32_t n); JANET_API void *janet_getpointer(const Janet *argv, int32_t n); JANET_API int32_t janet_getnat(const Janet *argv, int32_t n); JANET_API int32_t janet_getinteger(const Janet *argv, int32_t n); JANET_API int16_t janet_getinteger16(const Janet *argv, int32_t n); JANET_API int64_t janet_getinteger64(const Janet *argv, int32_t n); JANET_API uint32_t janet_getuinteger(const Janet *argv, int32_t n); JANET_API uint16_t janet_getuinteger16(const Janet *argv, int32_t n); JANET_API uint64_t janet_getuinteger64(const Janet *argv, int32_t n); JANET_API size_t janet_getsize(const Janet *argv, int32_t n); JANET_API JanetView janet_getindexed(const Janet *argv, int32_t n); JANET_API JanetByteView janet_getbytes(const Janet *argv, int32_t n); JANET_API JanetDictView janet_getdictionary(const Janet *argv, int32_t n); JANET_API void *janet_getabstract(const Janet *argv, int32_t n, const JanetAbstractType *at); JANET_API JanetRange janet_getslice(int32_t argc, const Janet *argv); JANET_API int32_t janet_gethalfrange(const Janet *argv, int32_t n, int32_t length, const char *which); JANET_API int32_t janet_getstartrange(const Janet *argv, int32_t argc, int32_t n, int32_t length); JANET_API int32_t janet_getendrange(const Janet *argv, int32_t argc, int32_t n, int32_t length); JANET_API int32_t janet_getargindex(const Janet *argv, int32_t n, int32_t length, const char *which); JANET_API uint64_t janet_getflags(const Janet *argv, int32_t n, const char *flags); /* Optionals */ JANET_API double janet_optnumber(const Janet *argv, int32_t argc, int32_t n, double dflt); JANET_API JanetTuple janet_opttuple(const Janet *argv, int32_t argc, int32_t n, JanetTuple dflt); JANET_API JanetStruct janet_optstruct(const Janet *argv, int32_t argc, int32_t n, JanetStruct dflt); JANET_API JanetString janet_optstring(const Janet *argv, int32_t argc, int32_t n, JanetString dflt); JANET_API const char *janet_optcstring(const Janet *argv, int32_t argc, int32_t n, const char *dflt); JANET_API const char *janet_optcbytes(const Janet *argv, int32_t argc, int32_t n, const char *dflt); JANET_API JanetSymbol janet_optsymbol(const Janet *argv, int32_t argc, int32_t n, JanetString dflt); JANET_API JanetKeyword janet_optkeyword(const Janet *argv, int32_t argc, int32_t n, JanetString dflt); JANET_API JanetFiber *janet_optfiber(const Janet *argv, int32_t argc, int32_t n, JanetFiber *dflt); JANET_API JanetFunction *janet_optfunction(const Janet *argv, int32_t argc, int32_t n, JanetFunction *dflt); JANET_API JanetCFunction janet_optcfunction(const Janet *argv, int32_t argc, int32_t n, JanetCFunction dflt); JANET_API int janet_optboolean(const Janet *argv, int32_t argc, int32_t n, int dflt); JANET_API void *janet_optpointer(const Janet *argv, int32_t argc, int32_t n, void *dflt); JANET_API int32_t janet_optnat(const Janet *argv, int32_t argc, int32_t n, int32_t dflt); JANET_API int32_t janet_optinteger(const Janet *argv, int32_t argc, int32_t n, int32_t dflt); JANET_API int64_t janet_optinteger64(const Janet *argv, int32_t argc, int32_t n, int64_t dflt); JANET_API size_t janet_optsize(const Janet *argv, int32_t argc, int32_t n, size_t dflt); JANET_API JanetAbstract janet_optabstract(const Janet *argv, int32_t argc, int32_t n, const JanetAbstractType *at, JanetAbstract dflt); JANET_API uint32_t janet_optuinteger(const Janet *argv, int32_t argc, int32_t n, uint32_t dflt); JANET_API uint64_t janet_optuinteger64(const Janet *argv, int32_t argc, int32_t n, uint64_t dflt); /* Mutable optional types specify a size default, and construct a new value if none is provided */ JANET_API JanetBuffer *janet_optbuffer(const Janet *argv, int32_t argc, int32_t n, int32_t dflt_len); JANET_API JanetTable *janet_opttable(const Janet *argv, int32_t argc, int32_t n, int32_t dflt_len); JANET_API JanetArray *janet_optarray(const Janet *argv, int32_t argc, int32_t n, int32_t dflt_len); JANET_API Janet janet_dyn(const char *name); JANET_API void janet_setdyn(const char *name, Janet value); extern JANET_API const JanetAbstractType janet_file_type; #define JANET_FILE_WRITE 1 #define JANET_FILE_READ 2 #define JANET_FILE_APPEND 4 #define JANET_FILE_UPDATE 8 #define JANET_FILE_NOT_CLOSEABLE 16 #define JANET_FILE_CLOSED 32 #define JANET_FILE_BINARY 64 #define JANET_FILE_SERIALIZABLE 128 #define JANET_FILE_NONIL 512 JANET_API Janet janet_makefile(FILE *f, int32_t flags); JANET_API JanetFile *janet_makejfile(FILE *f, int32_t flags); JANET_API FILE *janet_getfile(const Janet *argv, int32_t n, int32_t *flags); JANET_API FILE *janet_dynfile(const char *name, FILE *def); JANET_API JanetFile *janet_getjfile(const Janet *argv, int32_t n); JANET_API JanetAbstract janet_checkfile(Janet j); JANET_API FILE *janet_unwrapfile(Janet j, int32_t *flags); JANET_API int janet_file_close(JanetFile *file); JANET_API int janet_cryptorand(uint8_t *out, size_t n); /* Marshal API */ JANET_API void janet_marshal_size(JanetMarshalContext *ctx, size_t value); JANET_API void janet_marshal_int(JanetMarshalContext *ctx, int32_t value); JANET_API void janet_marshal_int64(JanetMarshalContext *ctx, int64_t value); JANET_API void janet_marshal_ptr(JanetMarshalContext *ctx, const void *value); JANET_API void janet_marshal_byte(JanetMarshalContext *ctx, uint8_t value); JANET_API void janet_marshal_bytes(JanetMarshalContext *ctx, const uint8_t *bytes, size_t len); JANET_API void janet_marshal_janet(JanetMarshalContext *ctx, Janet x); JANET_API void janet_marshal_abstract(JanetMarshalContext *ctx, JanetAbstract abstract); JANET_API void janet_unmarshal_ensure(JanetMarshalContext *ctx, size_t size); JANET_API size_t janet_unmarshal_size(JanetMarshalContext *ctx); JANET_API int32_t janet_unmarshal_int(JanetMarshalContext *ctx); JANET_API int64_t janet_unmarshal_int64(JanetMarshalContext *ctx); JANET_API void *janet_unmarshal_ptr(JanetMarshalContext *ctx); JANET_API uint8_t janet_unmarshal_byte(JanetMarshalContext *ctx); JANET_API void janet_unmarshal_bytes(JanetMarshalContext *ctx, uint8_t *dest, size_t len); JANET_API Janet janet_unmarshal_janet(JanetMarshalContext *ctx); JANET_API JanetAbstract janet_unmarshal_abstract(JanetMarshalContext *ctx, size_t size); JANET_API JanetAbstract janet_unmarshal_abstract_threaded(JanetMarshalContext *ctx, size_t size); JANET_API void janet_unmarshal_abstract_reuse(JanetMarshalContext *ctx, void *p); JANET_API void janet_register_abstract_type(const JanetAbstractType *at); JANET_API const JanetAbstractType *janet_get_abstract_type(Janet key); #ifdef JANET_PEG extern JANET_API const JanetAbstractType janet_peg_type; /* opcodes for peg vm */ typedef enum { RULE_LITERAL, /* [len, bytes...] */ RULE_NCHAR, /* [n] */ RULE_NOTNCHAR, /* [n] */ RULE_RANGE, /* [lo | hi << 16 (1 word)] */ RULE_SET, /* [bitmap (8 words)] */ RULE_LOOK, /* [offset, rule] */ RULE_CHOICE, /* [len, rules...] */ RULE_SEQUENCE, /* [len, rules...] */ RULE_IF, /* [rule_a, rule_b (b if a)] */ RULE_IFNOT, /* [rule_a, rule_b (b if not a)] */ RULE_NOT, /* [rule] */ RULE_BETWEEN, /* [lo, hi, rule] */ RULE_GETTAG, /* [searchtag, tag] */ RULE_CAPTURE, /* [rule, tag] */ RULE_POSITION, /* [tag] */ RULE_ARGUMENT, /* [argument-index, tag] */ RULE_CONSTANT, /* [constant, tag] */ RULE_ACCUMULATE, /* [rule, tag] */ RULE_GROUP, /* [rule, tag] */ RULE_REPLACE, /* [rule, constant, tag] */ RULE_MATCHTIME, /* [rule, constant, tag] */ RULE_ERROR, /* [rule] */ RULE_DROP, /* [rule] */ RULE_BACKMATCH, /* [tag] */ RULE_TO, /* [rule] */ RULE_THRU, /* [rule] */ RULE_LENPREFIX, /* [rule_a, rule_b (repeat rule_b rule_a times)] */ RULE_READINT, /* [(signedness << 4) | (endianness << 5) | bytewidth, tag] */ RULE_LINE, /* [tag] */ RULE_COLUMN, /* [tag] */ RULE_UNREF, /* [rule, tag] */ RULE_CAPTURE_NUM, /* [rule, tag] */ RULE_SUB, /* [rule, rule] */ RULE_TIL, /* [rule, rule] */ RULE_SPLIT, /* [rule, rule] */ RULE_NTH, /* [nth, rule, tag] */ RULE_ONLY_TAGS, /* [rule] */ RULE_MATCHSPLICE, /* [rule, constant, tag] */ RULE_DEBUG, /* [] */ } JanetPegOpcode; typedef struct { uint32_t *bytecode; Janet *constants; size_t bytecode_len; uint32_t num_constants; int has_backref; } JanetPeg; #endif #ifdef JANET_INT_TYPES extern JANET_API const JanetAbstractType janet_s64_type; extern JANET_API const JanetAbstractType janet_u64_type; typedef enum { JANET_INT_NONE, JANET_INT_S64, JANET_INT_U64 } JanetIntType; JANET_API JanetIntType janet_is_int(Janet x); JANET_API Janet janet_wrap_s64(int64_t x); JANET_API Janet janet_wrap_u64(uint64_t x); JANET_API int64_t janet_unwrap_s64(Janet x); JANET_API uint64_t janet_unwrap_u64(Janet x); JANET_API int janet_scan_int64(const uint8_t *str, int32_t len, int64_t *out); JANET_API int janet_scan_uint64(const uint8_t *str, int32_t len, uint64_t *out); #endif /* Custom allocator support */ JANET_API void *(janet_malloc)(size_t); JANET_API void *(janet_realloc)(void *, size_t); JANET_API void *(janet_calloc)(size_t, size_t); JANET_API void (janet_free)(void *); #ifndef janet_malloc #define janet_malloc(X) malloc((X)) #endif #ifndef janet_realloc #define janet_realloc(X, Y) realloc((X), (Y)) #endif #ifndef janet_calloc #define janet_calloc(X, Y) calloc((X), (Y)) #endif #ifndef janet_free #define janet_free(X) free((X)) #endif /***** END SECTION MAIN *****/ /* Re-enable popped variable length array warnings */ #ifdef _MSC_VER #pragma warning( pop ) #endif #ifdef __cplusplus } #endif #endif /* JANET_H_defined */ janet-1.41.2/src/mainclient/000077500000000000000000000000001514534607600156255ustar00rootroot00000000000000janet-1.41.2/src/mainclient/shell.c000066400000000000000000001107521514534607600171060ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #if !defined(_POSIX_C_SOURCE) #define _POSIX_C_SOURCE 200112L #endif #include #include #ifdef _WIN32 #include #include #ifndef ENABLE_VIRTUAL_TERMINAL_PROCESSING #define ENABLE_VIRTUAL_TERMINAL_PROCESSING 0x0004 #endif #ifndef ENABLE_VIRTUAL_TERMINAL_INPUT #define ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 #endif #endif void janet_line_init(); void janet_line_deinit(); void janet_line_get(const char *p, JanetBuffer *buffer); Janet janet_line_getter(int32_t argc, Janet *argv); static JANET_THREAD_LOCAL int gbl_cancel_current_repl_form = 0; /* * Line Editing */ static JANET_THREAD_LOCAL JanetTable *gbl_complete_env; /* Common */ Janet janet_line_getter(int32_t argc, Janet *argv) { janet_arity(argc, 0, 3); const char *str = (argc >= 1) ? (const char *) janet_getstring(argv, 0) : ""; JanetBuffer *buf = (argc >= 2) ? janet_getbuffer(argv, 1) : janet_buffer(10); gbl_complete_env = (argc >= 3) ? janet_gettable(argv, 2) : NULL; janet_line_get(str, buf); gbl_complete_env = NULL; Janet result; if (gbl_cancel_current_repl_form) { gbl_cancel_current_repl_form = 0; /* Signal that the user bailed out of the current form */ result = janet_ckeywordv("cancel"); } else { result = janet_wrap_buffer(buf); } return result; } static void simpleline(JanetBuffer *buffer) { FILE *in = janet_dynfile("in", stdin); buffer->count = 0; int c; for (;;) { c = fgetc(in); #ifndef JANET_PLAN9 if (c < 0 && !feof(in) && errno == EINTR) { continue; } #endif if (feof(in) || c < 0) { break; } janet_buffer_push_u8(buffer, (uint8_t) c); if (c == '\n') break; } } /* State */ #ifndef JANET_SIMPLE_GETLINE /* static state */ #define JANET_LINE_MAX 1024 #define JANET_MATCH_MAX 256 #define JANET_HISTORY_MAX 100 static JANET_THREAD_LOCAL int gbl_israwmode = 0; static JANET_THREAD_LOCAL const char *gbl_prompt = "> "; static JANET_THREAD_LOCAL int gbl_plen = 2; static JANET_THREAD_LOCAL char gbl_buf[JANET_LINE_MAX]; static JANET_THREAD_LOCAL int gbl_len = 0; static JANET_THREAD_LOCAL int gbl_pos = 0; static JANET_THREAD_LOCAL int gbl_cols = 80; static JANET_THREAD_LOCAL char *gbl_history[JANET_HISTORY_MAX]; static JANET_THREAD_LOCAL int gbl_history_count = 0; static JANET_THREAD_LOCAL int gbl_historyi = 0; static JANET_THREAD_LOCAL JanetByteView gbl_matches[JANET_MATCH_MAX]; static JANET_THREAD_LOCAL int gbl_match_count = 0; static JANET_THREAD_LOCAL int gbl_lines_below = 0; static JANET_THREAD_LOCAL int gbl_history_loaded = 0; static JANET_THREAD_LOCAL char *gbl_history_file = NULL; #endif /* Fallback */ #if defined(JANET_SIMPLE_GETLINE) void janet_line_init() { ; } void janet_line_deinit() { ; } void janet_line_get(const char *p, JanetBuffer *buffer) { FILE *out = janet_dynfile("err", stderr); fputs(p, out); fflush(out); simpleline(buffer); } /* Rich implementation */ #else /* Windows */ #ifdef _WIN32 #include #include #include #include static void setup_console_output(void) { /* Enable color console on windows 10 console and utf8 output and other processing */ HANDLE hOut = GetStdHandle(STD_OUTPUT_HANDLE); DWORD dwMode = 0; GetConsoleMode(hOut, &dwMode); dwMode |= ENABLE_VIRTUAL_TERMINAL_PROCESSING; dwMode |= ENABLE_PROCESSED_OUTPUT; SetConsoleMode(hOut, dwMode); if (IsValidCodePage(65001)) { SetConsoleOutputCP(65001); } } /* Ansi terminal raw mode */ static int rawmode(void) { if (gbl_israwmode) return 0; HANDLE hOut = GetStdHandle(STD_INPUT_HANDLE); DWORD dwMode = 0; GetConsoleMode(hOut, &dwMode); dwMode &= ~ENABLE_LINE_INPUT; dwMode &= ~ENABLE_INSERT_MODE; dwMode &= ~ENABLE_ECHO_INPUT; dwMode |= ENABLE_VIRTUAL_TERMINAL_INPUT; dwMode &= ~ENABLE_PROCESSED_INPUT; if (!SetConsoleMode(hOut, dwMode)) return 1; gbl_israwmode = 1; return 0; } /* Disable raw mode */ static void norawmode(void) { if (!gbl_israwmode) return; HANDLE hOut = GetStdHandle(STD_INPUT_HANDLE); DWORD dwMode = 0; GetConsoleMode(hOut, &dwMode); dwMode |= ENABLE_LINE_INPUT; dwMode |= ENABLE_INSERT_MODE; dwMode |= ENABLE_ECHO_INPUT; dwMode &= ~ENABLE_VIRTUAL_TERMINAL_INPUT; dwMode |= ENABLE_PROCESSED_INPUT; SetConsoleMode(hOut, dwMode); gbl_israwmode = 0; } static long write_console(const char *bytes, size_t n) { DWORD nwritten = 0; BOOL result = WriteConsole(GetStdHandle(STD_OUTPUT_HANDLE), bytes, (DWORD) n, &nwritten, NULL); if (!result) return -1; /* error */ return (long)nwritten; } static long read_console(char *into, size_t n) { DWORD numread; BOOL result = ReadConsole(GetStdHandle(STD_INPUT_HANDLE), into, (DWORD) n, &numread, NULL); if (!result) return -1; /* error */ return (long)numread; } static int check_simpleline(JanetBuffer *buffer) { if (!_isatty(_fileno(stdin)) || rawmode()) { simpleline(buffer); return 1; } return 0; } /* Posix */ #else /* https://github.com/antirez/linenoise/blob/master/linenoise.c */ #include #include #include #include #include #include #include #include #include #include #include #include static JANET_THREAD_LOCAL struct termios gbl_termios_start; /* Unsupported terminal list from linenoise */ static const char *badterms[] = { "cons25", "dumb", "emacs", NULL }; /* Ansi terminal raw mode */ static int rawmode(void) { struct termios t; if (!isatty(STDIN_FILENO)) goto fatal; if (tcgetattr(STDIN_FILENO, &gbl_termios_start) == -1) goto fatal; t = gbl_termios_start; t.c_iflag &= ~(BRKINT | ICRNL | INPCK | ISTRIP | IXON); t.c_cflag |= (CS8); t.c_lflag &= ~(ECHO | ICANON | IEXTEN | ISIG); t.c_cc[VMIN] = 1; t.c_cc[VTIME] = 0; if (tcsetattr(STDIN_FILENO, TCSADRAIN, &t) < 0) goto fatal; gbl_israwmode = 1; return 0; fatal: errno = ENOTTY; return -1; } /* Disable raw mode */ static void norawmode(void) { if (gbl_israwmode && tcsetattr(STDIN_FILENO, TCSADRAIN, &gbl_termios_start) != -1) gbl_israwmode = 0; } static int checktermsupport() { const char *t = getenv("TERM"); int i; if (!t) return 1; for (i = 0; badterms[i]; i++) if (!strcmp(t, badterms[i])) return 0; return 1; } static long write_console(char *bytes, size_t n) { return write(STDOUT_FILENO, bytes, n); } static long read_console(char *into, size_t n) { return read(STDIN_FILENO, into, n); } static int check_simpleline(JanetBuffer *buffer) { if (!isatty(STDIN_FILENO) || !checktermsupport()) { simpleline(buffer); return 1; } if (rawmode()) { simpleline(buffer); return 1; } return 0; } #endif static char *sdup(const char *s) { size_t len = strlen(s) + 1; char *mem = janet_malloc(len); if (!mem) { return NULL; } return memcpy(mem, s, len); } #ifndef _WIN32 static int curpos(void) { char buf[32]; int cols, rows; unsigned int i = 0; #ifndef JANET_PLAN9 if (write_console("\x1b[6n", 4) != 4) return -1; #endif while (i < sizeof(buf) - 1) { if (read_console(buf + i, 1) != 1) break; if (buf[i] == 'R') break; i++; } buf[i] = '\0'; if (buf[0] != 27 || buf[1] != '[') return -1; if (sscanf(buf + 2, "%d;%d", &rows, &cols) != 2) return -1; return cols; } #endif static int getcols(void) { #ifdef _WIN32 CONSOLE_SCREEN_BUFFER_INFO csbi; GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE), &csbi); return (int)(csbi.srWindow.Right - csbi.srWindow.Left + 1); #else struct winsize ws; if (ioctl(1, TIOCGWINSZ, &ws) == -1 || ws.ws_col == 0) { int start, cols; start = curpos(); if (start == -1) goto failed; if (write_console("\x1b[999C", 6) != 6) goto failed; cols = curpos(); if (cols == -1) goto failed; if (cols > start) { char seq[32]; snprintf(seq, 32, "\x1b[%dD", cols - start); if (write_console(seq, strlen(seq)) == -1) { exit(1); } } return cols; } else { return ws.ws_col; } failed: return 80; #endif } static void clear(void) { if (write_console("\x1b[H\x1b[2J", 7) <= 0) { exit(1); } } static void refresh(void) { char seq[64]; JanetBuffer b; /* Keep cursor position on screen */ char *_buf = gbl_buf; int _len = gbl_len; int _pos = gbl_pos; while ((gbl_plen + _pos) >= gbl_cols) { _buf++; _len--; _pos--; } while ((gbl_plen + _len) > gbl_cols) { _len--; } janet_buffer_init(&b, 0); /* Cursor to left edge, gbl_prompt and buffer */ janet_buffer_push_u8(&b, '\r'); janet_buffer_push_cstring(&b, gbl_prompt); janet_buffer_push_bytes(&b, (uint8_t *) _buf, _len); /* Erase to right */ janet_buffer_push_cstring(&b, "\x1b[0K\r"); /* Move cursor to original position. */ if (_pos + gbl_plen) { snprintf(seq, 64, "\x1b[%dC", (int)(_pos + gbl_plen)); janet_buffer_push_cstring(&b, seq); } if (write_console((char *) b.data, b.count) == -1) { exit(1); } janet_buffer_deinit(&b); } static void clearlines(void) { for (int i = 0; i < gbl_lines_below; i++) { fprintf(stderr, "\x1b[1B\x1b[999D\x1b[K"); } if (gbl_lines_below) { fprintf(stderr, "\x1b[%dA\x1b[999D", gbl_lines_below); fflush(stderr); gbl_lines_below = 0; } } static int insert(char c, int draw) { if (gbl_len < JANET_LINE_MAX - 1) { if (gbl_len == gbl_pos) { gbl_buf[gbl_pos++] = c; gbl_buf[++gbl_len] = '\0'; if (draw) { if (gbl_plen + gbl_len < gbl_cols) { /* Avoid a full update of the line in the * trivial case. */ if (write_console(&c, 1) == -1) return -1; } else { refresh(); } } } else { memmove(gbl_buf + gbl_pos + 1, gbl_buf + gbl_pos, gbl_len - gbl_pos); gbl_buf[gbl_pos++] = c; gbl_buf[++gbl_len] = '\0'; if (draw) refresh(); } } return 0; } static void calc_history_file(void) { char *hist = getenv("JANET_HISTFILE"); if (hist != NULL) { gbl_history_file = sdup(hist); } else { gbl_history_file = NULL; } } static void loadhistory(void) { if (gbl_history_loaded) return; calc_history_file(); gbl_history_loaded = 1; if (NULL == gbl_history_file) return; FILE *history_file = fopen(gbl_history_file, "rb"); if (NULL == history_file) return; JanetParser p; janet_parser_init(&p); int c = 0; while ((c = fgetc(history_file))) { if (c == EOF) { janet_parser_eof(&p); } else { janet_parser_consume(&p, c); } while (janet_parser_has_more(&p) && gbl_history_count < JANET_HISTORY_MAX) { if (janet_parser_status(&p) == JANET_PARSE_ERROR) { janet_eprintf("bad history file: %s\n", janet_parser_error(&p)); goto parsing_done; } Janet x = janet_parser_produce(&p); const char *cstr = (const char *) janet_to_string(x); if (cstr[0]) { /* Drop empty strings */ gbl_history[gbl_history_count++] = sdup(cstr); } } if (c == EOF) break; } parsing_done: janet_parser_deinit(&p); gbl_historyi = 0; fclose(history_file); } static void savehistory(void) { if (gbl_history_count < 1 || (gbl_history_file == NULL)) return; FILE *history_file = fopen(gbl_history_file, "wb"); for (int i = 0; i < gbl_history_count; i++) { if (gbl_history[i][0]) { /* Drop empty strings */ janet_dynprintf(NULL, history_file, "%j\n", janet_cstringv(gbl_history[i])); } } fclose(history_file); } static void historymove(int delta) { if (gbl_history_count > 1) { janet_free(gbl_history[gbl_historyi]); gbl_history[gbl_historyi] = sdup(gbl_buf); gbl_historyi += delta; if (gbl_historyi < 0) { gbl_historyi = 0; } else if (gbl_historyi >= gbl_history_count) { gbl_historyi = gbl_history_count - 1; } strncpy(gbl_buf, gbl_history[gbl_historyi], JANET_LINE_MAX - 1); gbl_pos = gbl_len = (int) strlen(gbl_buf); gbl_buf[gbl_len] = '\0'; refresh(); } } static void addhistory(void) { int i, len; char *newline = sdup(gbl_buf); if (!newline) return; len = gbl_history_count; if (len < JANET_HISTORY_MAX) { gbl_history[gbl_history_count++] = newline; len++; } else { janet_free(gbl_history[JANET_HISTORY_MAX - 1]); } for (i = len - 1; i > 0; i--) { gbl_history[i] = gbl_history[i - 1]; } gbl_history[0] = newline; } static void replacehistory(void) { /* History count is always > 0 here */ if (gbl_len == 0 || (gbl_history_count > 1 && !strcmp(gbl_buf, gbl_history[1]))) { /* Delete history */ janet_free(gbl_history[0]); for (int i = 1; i < gbl_history_count; i++) { gbl_history[i - 1] = gbl_history[i]; } gbl_history_count--; } else { char *newline = sdup(gbl_buf); if (!newline) return; janet_free(gbl_history[0]); gbl_history[0] = newline; } } static void kleft(void) { if (gbl_pos > 0) { gbl_pos--; refresh(); } } static void kleftw(void) { while (gbl_pos > 0 && isspace(gbl_buf[gbl_pos - 1])) { gbl_pos--; } while (gbl_pos > 0 && !isspace(gbl_buf[gbl_pos - 1])) { gbl_pos--; } refresh(); } static void kright(void) { if (gbl_pos != gbl_len) { gbl_pos++; refresh(); } } static void krightw(void) { while (gbl_pos != gbl_len && isspace(gbl_buf[gbl_pos])) { gbl_pos++; } while (gbl_pos != gbl_len && !isspace(gbl_buf[gbl_pos])) { gbl_pos++; } refresh(); } static void kbackspace(int draw) { if (gbl_pos > 0) { memmove(gbl_buf + gbl_pos - 1, gbl_buf + gbl_pos, gbl_len - gbl_pos); gbl_pos--; gbl_buf[--gbl_len] = '\0'; if (draw) refresh(); } } static void kdelete(int draw) { if (gbl_pos != gbl_len) { memmove(gbl_buf + gbl_pos, gbl_buf + gbl_pos + 1, gbl_len - gbl_pos); gbl_buf[--gbl_len] = '\0'; if (draw) refresh(); } } static void kbackspacew(void) { while (gbl_pos && isspace(gbl_buf[gbl_pos - 1])) { kbackspace(0); } while (gbl_pos && !isspace(gbl_buf[gbl_pos - 1])) { kbackspace(0); } refresh(); } static void kdeletew(void) { while (gbl_pos < gbl_len && isspace(gbl_buf[gbl_pos])) { kdelete(0); } while (gbl_pos < gbl_len && !isspace(gbl_buf[gbl_pos])) { kdelete(0); } refresh(); } /* See tools/symchargen.c */ static int is_symbol_char_gen(uint8_t c) { if (c & 0x80) return 1; if (c >= 'a' && c <= 'z') return 1; if (c >= 'A' && c <= 'Z') return 1; if (c >= '0' && c <= '9') return 1; return (c == '!' || c == '$' || c == '%' || c == '&' || c == '*' || c == '+' || c == '-' || c == '.' || c == '/' || c == ':' || c == '<' || c == '?' || c == '=' || c == '>' || c == '@' || c == '^' || c == '_'); } static JanetByteView get_symprefix(void) { /* Calculate current partial symbol. Maybe we could actually hook up the Janet * parser here...*/ int i; JanetByteView ret; ret.len = 0; for (i = gbl_pos - 1; i >= 0; i--) { uint8_t c = (uint8_t) gbl_buf[i]; if (!is_symbol_char_gen(c)) break; ret.len++; } /* Will be const for duration of match checking */ ret.bytes = (const uint8_t *)(gbl_buf + i + 1); return ret; } static int compare_bytes(JanetByteView a, JanetByteView b) { int32_t minlen = a.len < b.len ? a.len : b.len; int result = strncmp((const char *) a.bytes, (const char *) b.bytes, minlen); if (result) return result; return a.len < b.len ? -1 : a.len > b.len ? 1 : 0; } static void check_match(JanetByteView src, const uint8_t *testsym, int32_t testlen) { JanetByteView test; test.bytes = testsym; test.len = testlen; if (src.len > test.len || strncmp((const char *) src.bytes, (const char *) test.bytes, src.len)) return; JanetByteView mm = test; for (int i = 0; i < gbl_match_count; i++) { if (compare_bytes(mm, gbl_matches[i]) < 0) { JanetByteView temp = mm; mm = gbl_matches[i]; gbl_matches[i] = temp; } } if (gbl_match_count == JANET_MATCH_MAX) return; gbl_matches[gbl_match_count++] = mm; } static void check_cmatch(JanetByteView src, const char *cstr) { check_match(src, (const uint8_t *) cstr, (int32_t) strlen(cstr)); } static JanetByteView longest_common_prefix(void) { JanetByteView bv; if (gbl_match_count == 0) { bv.len = 0; bv.bytes = NULL; } else { bv = gbl_matches[0]; for (int i = 0; i < gbl_match_count; i++) { JanetByteView other = gbl_matches[i]; int32_t minlen = other.len < bv.len ? other.len : bv.len; for (bv.len = 0; bv.len < minlen; bv.len++) { if (bv.bytes[bv.len] != other.bytes[bv.len]) { break; } } } } return bv; } static void check_specials(JanetByteView src) { check_cmatch(src, "break"); check_cmatch(src, "def"); check_cmatch(src, "do"); check_cmatch(src, "fn"); check_cmatch(src, "if"); check_cmatch(src, "quasiquote"); check_cmatch(src, "quote"); check_cmatch(src, "set"); check_cmatch(src, "splice"); check_cmatch(src, "unquote"); check_cmatch(src, "var"); check_cmatch(src, "while"); check_cmatch(src, "upscope"); } static void resolve_format(JanetTable *entry) { int is_macro = janet_truthy(janet_table_get(entry, janet_ckeywordv("macro"))); Janet refv = janet_table_get(entry, janet_ckeywordv("ref")); int is_ref = janet_checktype(refv, JANET_ARRAY); Janet value = janet_wrap_nil(); if (is_ref) { JanetArray *a = janet_unwrap_array(refv); if (a->count) value = a->data[0]; } else { value = janet_table_get(entry, janet_ckeywordv("value")); } if (is_macro) { fprintf(stderr, " macro\n"); gbl_lines_below++; } else if (is_ref) { janet_eprintf(" var (%t)\n", value); gbl_lines_below++; } else { janet_eprintf(" %t\n", value); gbl_lines_below++; } Janet sm = janet_table_get(entry, janet_ckeywordv("source-map")); Janet path = janet_get(sm, janet_wrap_integer(0)); Janet line = janet_get(sm, janet_wrap_integer(1)); Janet col = janet_get(sm, janet_wrap_integer(2)); if (janet_checktype(path, JANET_STRING) && janet_truthy(line) && janet_truthy(col)) { janet_eprintf(" %S on line %v, column %v\n", janet_unwrap_string(path), line, col); gbl_lines_below++; } } static void doc_format(JanetString doc, int32_t width) { int32_t maxcol = width - 8; uint8_t wordbuf[256] = {0}; int32_t wordp = 0; int32_t current = 0; if (maxcol > 200) maxcol = 200; fprintf(stderr, " "); for (int32_t i = 0; i < janet_string_length(doc); i++) { uint8_t b = doc[i]; switch (b) { default: { if (maxcol <= current + wordp + 1) { if (!current) { fwrite(wordbuf, wordp, 1, stderr); wordp = 0; } fprintf(stderr, "\n "); gbl_lines_below++; current = 0; } wordbuf[wordp++] = b; break; } case '\t': { if (maxcol <= current + wordp + 2) { if (!current) { fwrite(wordbuf, wordp, 1, stderr); wordp = 0; } fprintf(stderr, "\n "); gbl_lines_below++; current = 0; } wordbuf[wordp++] = ' '; wordbuf[wordp++] = ' '; break; } case '\n': case ' ': { if (wordp) { int32_t oldcur = current; int spacer = maxcol > current + wordp + 1; if (spacer) current++; else current = 0; current += wordp; if (oldcur) fprintf(stderr, spacer ? " " : "\n "); if (oldcur && !spacer) gbl_lines_below++; fwrite(wordbuf, wordp, 1, stderr); wordp = 0; } if (b == '\n') { fprintf(stderr, "\n "); gbl_lines_below++; current = 0; } } } } if (wordp) { int32_t oldcur = current; int spacer = maxcol > current + wordp + 1; if (spacer) current++; else current = 0; current += wordp + 1; if (oldcur) fprintf(stderr, spacer ? " " : "\n "); if (oldcur && !spacer) gbl_lines_below++; fwrite(wordbuf, wordp, 1, stderr); wordp = 0; } } static void find_matches(JanetByteView prefix) { JanetTable *env = gbl_complete_env; gbl_match_count = 0; while (NULL != env) { JanetKV *kvend = env->data + env->capacity; for (JanetKV *kv = env->data; kv < kvend; kv++) { if (!janet_checktype(kv->key, JANET_SYMBOL)) continue; const uint8_t *sym = janet_unwrap_symbol(kv->key); check_match(prefix, sym, janet_string_length(sym)); } env = env->proto; } } static void kshowdoc(void) { if (!gbl_complete_env) return; while (is_symbol_char_gen(gbl_buf[gbl_pos])) gbl_pos++; JanetByteView prefix = get_symprefix(); Janet symbol = janet_symbolv(prefix.bytes, prefix.len); Janet entry = janet_table_get(gbl_complete_env, symbol); if (!janet_checktype(entry, JANET_TABLE)) return; Janet doc = janet_table_get(janet_unwrap_table(entry), janet_ckeywordv("doc")); if (!janet_checktype(doc, JANET_STRING)) return; JanetString docs = janet_unwrap_string(doc); int num_cols = getcols(); clearlines(); fprintf(stderr, "\n\n\n"); gbl_lines_below += 3; resolve_format(janet_unwrap_table(entry)); fprintf(stderr, "\n"); gbl_lines_below += 1; doc_format(docs, num_cols); fprintf(stderr, "\n\n"); gbl_lines_below += 2; /* Go up to original line (zsh-like autocompletion) */ fprintf(stderr, "\x1B[%dA", gbl_lines_below); fflush(stderr); } static void kshowcomp(void) { JanetTable *env = gbl_complete_env; if (env == NULL) { insert(' ', 0); insert(' ', 0); return; } /* Advance while on symbol char */ while (is_symbol_char_gen(gbl_buf[gbl_pos])) gbl_pos++; JanetByteView prefix = get_symprefix(); if (prefix.len == 0) return; find_matches(prefix); check_specials(prefix); JanetByteView lcp = longest_common_prefix(); for (int i = prefix.len; i < lcp.len; i++) { insert(lcp.bytes[i], 0); } if (!gbl_lines_below && prefix.len != lcp.len) return; int32_t maxlen = 0; for (int i = 0; i < gbl_match_count; i++) if (gbl_matches[i].len > maxlen) maxlen = gbl_matches[i].len; int num_cols = getcols(); clearlines(); if (gbl_match_count >= 2) { /* Second pass, print */ int col_width = maxlen + 4; int cols = num_cols / col_width; if (cols == 0) cols = 1; int current_col = 0; for (int i = 0; i < gbl_match_count; i++) { if (current_col == 0) { putc('\n', stderr); gbl_lines_below++; } JanetByteView s = gbl_matches[i]; fprintf(stderr, "%s", (const char *) s.bytes); for (int j = s.len; j < col_width; j++) { putc(' ', stderr); } current_col = (current_col + 1) % cols; } /* Go up to original line (zsh-like autocompletion) */ fprintf(stderr, "\x1B[%dA", gbl_lines_below); fflush(stderr); } } static int line() { gbl_cols = getcols(); gbl_plen = 0; gbl_len = 0; gbl_pos = 0; while (gbl_prompt[gbl_plen]) gbl_plen++; gbl_buf[0] = '\0'; addhistory(); if (write_console((char *) gbl_prompt, gbl_plen) == -1) return -1; for (;;) { char c; char seq[5]; int rc; do { rc = read_console(&c, 1); } while (rc < 0 && errno == EINTR); if (rc <= 0) return -1; switch (c) { default: if ((unsigned char) c < 0x20) break; if (insert(c, 1)) return -1; break; case 1: /* ctrl-a */ gbl_pos = 0; refresh(); break; case 2: /* ctrl-b */ kleft(); break; case 3: /* ctrl-c */ clearlines(); norawmode(); savehistory(); #ifdef _WIN32 ExitProcess(1); #else kill(getpid(), SIGINT); #endif /* fallthrough */ case 17: /* ctrl-q */ gbl_cancel_current_repl_form = 1; clearlines(); return -1; case 4: /* ctrl-d, eof */ if (gbl_len == 0) { /* quit on empty line */ clearlines(); return -1; } kdelete(1); break; case 5: /* ctrl-e */ gbl_pos = gbl_len; refresh(); break; case 6: /* ctrl-f */ kright(); break; case 7: /* ctrl-g */ kshowdoc(); refresh(); break; case 127: /* backspace */ case 8: /* ctrl-h */ kbackspace(1); break; case 9: /* tab */ kshowcomp(); refresh(); break; case 11: /* ctrl-k */ gbl_buf[gbl_pos] = '\0'; gbl_len = gbl_pos; refresh(); break; case 12: /* ctrl-l */ clear(); refresh(); break; case 13: /* enter */ clearlines(); return 0; case 14: /* ctrl-n */ historymove(-1); break; case 16: /* ctrl-p */ historymove(1); break; case 21: { /* ctrl-u */ memmove(gbl_buf, gbl_buf + gbl_pos, gbl_len - gbl_pos); gbl_len -= gbl_pos; gbl_buf[gbl_len] = '\0'; gbl_pos = 0; refresh(); break; } case 23: /* ctrl-w */ kbackspacew(); break; #ifndef _WIN32 case 26: /* ctrl-z */ clearlines(); norawmode(); kill(getpid(), SIGSTOP); rawmode(); refresh(); break; #endif case 27: /* escape sequence */ /* Read the next two bytes representing the escape sequence. * Use two calls to handle slow terminals returning the two * chars at different times. */ if (read_console(seq, 1) == -1) break; /* Esc[ = Control Sequence Introducer (CSI) */ if (seq[0] == '[') { if (read_console(seq + 1, 1) == -1) break; if (seq[1] >= '0' && seq[1] <= '9') { /* Extended escape, read additional byte. */ if (read_console(seq + 2, 1) == -1) break; if (seq[2] == '~') { switch (seq[1]) { case '1': /* Home */ gbl_pos = 0; refresh(); break; case '3': /* delete */ kdelete(1); break; case '4': /* End */ gbl_pos = gbl_len; refresh(); break; default: break; } } else if (seq[2] == ';') { if (read_console(seq + 3, 2) == -1) break; if (seq[3] == '5') { switch (seq[4]) { case 'C': /* ctrl-right */ krightw(); break; case 'D': /* ctrl-left */ kleftw(); break; default: break; } } } } else if (seq[0] == 'O') { if (read_console(seq + 1, 1) == -1) break; switch (seq[1]) { default: break; case 'H': /* Home (some keyboards) */ gbl_pos = 0; refresh(); break; case 'F': /* End (some keyboards) */ gbl_pos = gbl_len; refresh(); break; } } else { switch (seq[1]) { /* Single escape sequences */ default: break; case 'A': /* Up */ historymove(1); break; case 'B': /* Down */ historymove(-1); break; case 'C': /* Right */ kright(); break; case 'D': /* Left */ kleft(); break; case 'H': /* Home */ gbl_pos = 0; refresh(); break; case 'F': /* End */ gbl_pos = gbl_len; refresh(); break; } } } else { /* Check alt-(shift) bindings */ switch (seq[0]) { default: break; case 'd': /* Alt-d */ kdeletew(); break; case 'b': /* Alt-b */ kleftw(); break; case 'f': /* Alt-f */ krightw(); break; case ',': /* Alt-, */ historymove(JANET_HISTORY_MAX); break; case '.': /* Alt-. */ historymove(-JANET_HISTORY_MAX); break; case 127: /* Alt-backspace */ kbackspacew(); break; } } break; } } return 0; } void janet_line_init() { ; } void janet_line_deinit() { norawmode(); for (int i = 0; i < gbl_history_count; i++) janet_free(gbl_history[i]); gbl_historyi = 0; if (gbl_history_file) { janet_free(gbl_history_file); gbl_history_file = NULL; } } void janet_line_get(const char *p, JanetBuffer *buffer) { gbl_prompt = p; buffer->count = 0; gbl_historyi = 0; loadhistory(); if (check_simpleline(buffer)) return; FILE *out = janet_dynfile("err", stderr); if (line()) { norawmode(); fputc('\n', out); return; } fflush(stdin); norawmode(); fputc('\n', out); janet_buffer_ensure(buffer, gbl_len + 1, 2); memcpy(buffer->data, gbl_buf, gbl_len); buffer->data[gbl_len] = '\n'; buffer->count = gbl_len + 1; replacehistory(); } static void clear_at_exit(void) { if (!gbl_israwmode) { clearlines(); norawmode(); } } #endif /* * Entry */ int main(int argc, char **argv) { int i, status; JanetArray *args; JanetTable *env; #ifdef JANET_PLAN9 setfcr(0); #endif #ifdef _WIN32 setup_console_output(); #endif #if !defined(JANET_SIMPLE_GETLINE) atexit(clear_at_exit); #endif #if defined(JANET_PRF) uint8_t hash_key[JANET_HASH_KEY_SIZE + 1]; #ifdef JANET_REDUCED_OS char *envvar = NULL; #else char *envvar = getenv("JANET_HASHSEED"); #endif if (NULL != envvar) { strncpy((char *) hash_key, envvar, sizeof(hash_key) - 1); } else if (janet_cryptorand(hash_key, JANET_HASH_KEY_SIZE) != 0) { fputs("unable to initialize janet PRF hash function.\n", stderr); return 1; } janet_init_hash_key(hash_key); #endif /* Set up VM */ janet_init(); /* Replace original getline with new line getter */ JanetTable *replacements = janet_table(0); janet_table_put(replacements, janet_csymbolv("getline"), janet_wrap_cfunction(janet_line_getter)); janet_line_init(); /* Get core env */ env = janet_core_env(replacements); /* Create args tuple */ args = janet_array(argc); for (i = 1; i < argc; i++) janet_array_push(args, janet_cstringv(argv[i])); /* Save current executable path to (dyn :executable) */ janet_table_put(env, janet_ckeywordv("executable"), janet_cstringv(argv[0])); /* Run startup script */ Janet mainfun; janet_resolve(env, janet_csymbol("cli-main"), &mainfun); Janet mainargs[1] = { janet_wrap_array(args) }; JanetFiber *fiber = janet_fiber(janet_unwrap_function(mainfun), 64, 1, mainargs); janet_gcroot(janet_wrap_fiber(fiber)); fiber->env = env; /* Run the fiber in an event loop */ status = janet_loop_fiber(fiber); /* Deinitialize vm */ #if !defined(JANET_SIMPLE_GETLINE) savehistory(); #endif janet_deinit(); janet_line_deinit(); return status; } janet-1.41.2/test/000077500000000000000000000000001514534607600136725ustar00rootroot00000000000000janet-1.41.2/test/amalg/000077500000000000000000000000001514534607600147535ustar00rootroot00000000000000janet-1.41.2/test/amalg/main.c000066400000000000000000000026471514534607600160540ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ /* A simple client for checking if the amalgamated Janet source compiles * correctly. */ #include int main(int argc, const char *argv[]) { (void) argc; (void) argv; janet_init(); JanetTable *env = janet_core_env(NULL); janet_dostring(env, "(print `hello, world!`)", "main", NULL); janet_deinit(); return 0; } janet-1.41.2/test/fuzzers/000077500000000000000000000000001514534607600154025ustar00rootroot00000000000000janet-1.41.2/test/fuzzers/fuzz_dostring.c000066400000000000000000000021161514534607600204550ustar00rootroot00000000000000#include #include #include int LLVMFuzzerTestOneInput(const uint8_t *data, size_t size) { /* init Janet */ janet_init(); /* fuzz the parser */ JanetParser parser; janet_parser_init(&parser); for (int i = 0, done = 0; i < size; i++) { switch (janet_parser_status(&parser)) { case JANET_PARSE_DEAD: case JANET_PARSE_ERROR: done = 1; break; case JANET_PARSE_PENDING: if (i == size) { janet_parser_eof(&parser); } else { janet_parser_consume(&parser, data[i]); } break; case JANET_PARSE_ROOT: if (i >= size) { janet_parser_eof(&parser); } else { janet_parser_consume(&parser, data[i]); } break; } if (done == 1) break; } janet_parser_deinit(&parser); /* cleanup Janet */ janet_deinit(); return 0; } janet-1.41.2/test/helper.janet000066400000000000000000000053031514534607600161750ustar00rootroot00000000000000# Helper code for running tests # Turn on strict linting by default in test suite. (put root-env *lint-warn* :strict) (var num-tests-passed 0) (var num-tests-run 0) (var suite-name 0) (var start-time 0) (var skip-count 0) (var skip-n 0) (var is-verbose (os/getenv "VERBOSE")) (defn- assert-no-tail "Override's the default assert with some nice error handling." [x &opt e] (++ num-tests-run) (when (pos? skip-n) (-- skip-n) (++ skip-count) (break x)) (default e "assert error") (when x (++ num-tests-passed)) (def stack (debug/stack (fiber/current))) (def frame (last stack)) (def line-info (string/format "%s:%d" (frame :source) (frame :source-line))) (if x (when is-verbose (eprintf "\e[32m✔\e[0m %s: %s: %v" line-info (describe e) x)) (do (eprintf "\e[31m✘\e[0m %s: %s: %v" line-info (describe e) x) (eflush))) x) (defn skip-asserts "Skip some asserts" [n] (+= skip-n n) nil) (defmacro assert [x &opt e] (def xx (gensym)) (default e (string/format "%j" x)) ~(do (def ,xx ,x) (,assert-no-tail ,xx ,e) ,xx)) (defmacro assert-error [msg & forms] (def errsym (keyword (gensym))) ~(assert (= ,errsym (try (do ,;forms) ([_] ,errsym))) ,msg)) (defmacro assert-error-value [msg errval & forms] (def e (gensym)) ~(assert (= ,errval (try (do ,;forms) ([,e] ,e))) ,msg)) (defn check-compile-error [form] (def result (compile form)) (assert (table? result) (string/format "expected compilation error for %j, but compiled without error" form))) (defmacro assert-no-error [msg & forms] (def e (gensym)) (def f (gensym)) (if is-verbose ~(try (do ,;forms (as-macro ,assert true ,msg)) ([,e ,f] (as-macro ,assert false ,msg) (,debug/stacktrace ,f ,e "\e[31m✘\e[0m "))) ~(try (do ,;forms (as-macro ,assert true ,msg)) ([_] (as-macro ,assert false ,msg))))) (defn start-suite [&opt x] (default x (dyn :current-file)) (set suite-name (cond (number? x) (string x) (string x))) (set start-time (os/clock)) (eprint "Starting suite " suite-name "...")) (defn end-suite [] (def delta (- (os/clock) start-time)) (eprinf "Finished suite %s in %.3f seconds - " suite-name delta) (eprint num-tests-passed " of " num-tests-run " tests passed (" skip-count " skipped).") (if (not= (+ skip-count num-tests-passed) num-tests-run) (os/exit 1))) (defn rmrf "rm -rf in janet" [x] (case (os/lstat x :mode) nil nil :directory (do (each y (os/dir x) (rmrf (string x "/" y))) (os/rmdir x)) (os/rm x)) nil) (defn randdir "Get a random directory name" [] (string "tmp_dir_" (slice (string (math/random) ".tmp") 2))) janet-1.41.2/test/suite-array.janet000066400000000000000000000075421514534607600171720ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Array tests # e05022f (defn array= "Check if two arrays are equal in an element by element comparison" [a b] (if (and (array? a) (array? b)) (= (apply tuple a) (apply tuple b)))) (assert (= (apply tuple @[1 2 3 4 5]) (tuple 1 2 3 4 5)) "array to tuple") (def arr (array)) (array/push arr :hello) (array/push arr :world) (assert (array= arr @[:hello :world]) "array comparison") (assert (array= @[1 2 3 4 5] @[1 2 3 4 5]) "array comparison 2") (assert (array= @[:one :two :three :four :five] @[:one :two :three :four :five]) "array comparison 3") (assert (array= (array/slice @[1 2 3] 0 2) @[1 2]) "array/slice 1") (assert (array= (array/slice @[0 7 3 9 1 4] 2 -2) @[3 9 1]) "array/slice 2") # Array remove # 687a3c9 (assert (deep= (array/remove @[1 2 3 4 5] 2) @[1 2 4 5]) "array/remove 1") (assert (deep= (array/remove @[1 2 3 4 5] 2 2) @[1 2 5]) "array/remove 2") (assert (deep= (array/remove @[1 2 3 4 5] 2 200) @[1 2]) "array/remove 3") (assert (deep= (array/remove @[1 2 3 4 5] -2 200) @[1 2 3]) "array/remove 4") # array/peek (assert (nil? (array/peek @[])) "array/peek empty") # array/fill (assert (deep= (array/fill @[1 1] 2) @[2 2]) "array/fill 1") # array/concat (assert (deep= (array/concat @[1 2] @[3 4] 5 6) @[1 2 3 4 5 6]) "array/concat 1") (def a @[1 2]) (assert (deep= (array/concat a a) @[1 2 1 2]) "array/concat self") # array/insert (assert (deep= (array/insert @[:a :a :a :a] 2 :b :b) @[:a :a :b :b :a :a]) "array/insert 1") (assert (deep= (array/insert @[:a :b] -1 :c :d) @[:a :b :c :d]) "array/insert 2") # array/remove (assert-error "removal index 3 out of range [0,2]" (array/remove @[1 2] 3)) (assert-error "expected non-negative integer for argument n, got -1" (array/remove @[1 2] 1 -1)) # array/pop (assert (= (array/pop @[1]) 1) "array/pop 1") (assert (= (array/pop @[]) nil) "array/pop empty") # Code coverage (def a @[1]) (array/pop a) (array/trim a) (array/ensure @[1 1] 6 2) # array/join (assert (deep= @[1 2 3] (array/join @[] [1] [2] [3])) "array/join 1") (assert (deep= @[] (array/join @[])) "array/join 2") (assert (deep= @[1 :a :b :c] (array/join @[1] @[:a :b] [] [:c])) "array/join 3") (assert (deep= @[:x :y :z "abc123" "def456"] (array/join @[:x :y :z] ["abc123" "def456"])) "array/join 4") (assert-error "array/join error 1" (array/join)) (assert-error "array/join error 2" (array/join [])) (assert-error "array/join error 3" (array/join [] "abc123")) (assert-error "array/join error 4" (array/join @[] "abc123")) (assert-error "array/join error 5" (array/join @[] "abc123")) # Regression 1714 (repeat 10 (assert (deep= (put @[] 100 10) (put (seq [_ :range [0 101]] nil) 100 10)) "regression 1714") (assert (deep= (put @[] 200 10) (put (seq [_ :range [0 201]] nil) 200 10)) "regression 1714")) (end-suite) janet-1.41.2/test/suite-asm.janet000066400000000000000000000044021514534607600166240ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) (setdyn *lint-warn* :none) # Assembly test # Fibonacci sequence, implemented with naive recursion. # a679f60 (def fibasm (asm '{ :arity 1 :bytecode [ (ltim 1 0 0x2) # $1 = $0 < 2 (jmpif 1 :done) # if ($1) goto :done (lds 1) # $1 = self (addim 0 0 -0x1) # $0 = $0 - 1 (push 0) # push($0), push argument for next function call (call 2 1) # $2 = call($1) (addim 0 0 -0x1) # $0 = $0 - 1 (push 0) # push($0) (call 0 1) # $0 = call($1) (add 0 0 2) # $0 = $0 + $2 (integers) :done (ret 0) # return $0 ] })) (assert (= 0 (fibasm 0)) "fibasm 1") (assert (= 1 (fibasm 1)) "fibasm 2") (assert (= 55 (fibasm 10)) "fibasm 3") (assert (= 6765 (fibasm 20)) "fibasm 4") # dacbe29 (def f (asm (disasm (fn [x] (fn [y] (+ x y)))))) (assert (= ((f 10) 37) 47) "asm environment tables") # issue #1424 (assert-no-error "arity > used slots (issue #1424)" (asm (disasm (fn [] (def foo (fn [one two] one)) (foo 100 200))))) (end-suite) janet-1.41.2/test/suite-boot.janet000066400000000000000000001063361514534607600170200ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) (setdyn *lint-warn* :none) # Let # 807f981 (assert (= (let [a 1 b 2] (+ a b)) 3) "simple let") (assert (= (let [[a b] @[1 2]] (+ a b)) 3) "destructured let") (assert (= (let [[a [c d] b] @[1 (tuple 4 3) 2]] (+ a b c d)) 10) "double destructured let") # Macros # b305a7c (defn dub [x] (+ x x)) (assert (= 2 (dub 1)) "defn macro") (do (defn trip [x] (+ x x x)) (assert (= 3 (trip 1)) "defn macro triple")) (do (var i 0) (when true (++ i) (++ i) (++ i) (++ i) (++ i) (++ i)) (assert (= i 6) "when macro")) # Add truthy? to core # ded08b6 (assert (= true ;(map truthy? [0 "" true @{} {} [] '()])) "truthy values") (assert (= false ;(map truthy? [nil false])) "non-truthy values") ## Polymorphic comparison -- Issue #272 # 81d301a42 # confirm polymorphic comparison delegation to primitive comparators: (assert (= 0 (cmp 3 3)) "compare-primitive integers (1)") (assert (= -1 (cmp 3 5)) "compare-primitive integers (2)") (assert (= 1 (cmp "foo" "bar")) "compare-primitive strings") (assert (= 0 (compare 1 1)) "compare integers (1)") (assert (= -1 (compare 1 2)) "compare integers (2)") (assert (= 1 (compare "foo" "bar")) "compare strings (1)") (assert (compare< 1 2 3 4 5 6) "compare less than integers") (assert (not (compare> 1 2 3 4 5 6)) "compare not greater than integers") (assert (compare< 1.0 2.0 3.0 4.0 5.0 6.0) "compare less than reals") (assert (compare> 6 5 4 3 2 1) "compare greater than integers") (assert (compare> 6.0 5.0 4.0 3.0 2.0 1.0) "compare greater than reals") (assert (not (compare< 6.0 5.0 4.0 3.0 2.0 1.0)) "compare less than reals") (assert (compare<= 1 2 3 3 4 5 6) "compare less than or equal to integers") (assert (compare<= 1.0 2.0 3.0 3.0 4.0 5.0 6.0) "compare less than or equal to reals") (assert (compare>= 6 5 4 4 3 2 1) "compare greater than or equal to integers") (assert (compare>= 6.0 5.0 4.0 4.0 3.0 2.0 1.0) "compare greater than or equal to reals") (assert (compare< 1.0 nil false true (fiber/new (fn [] 1)) "hi" (quote hello) :hello (array 1 2 3) (tuple 1 2 3) (table "a" "b" "c" "d") (struct 1 2 3 4) (buffer "hi") (fn [x] (+ x x)) print) "compare type ordering") # test polymorphic compare with 'objects' (table/setproto) (def mynum @{:type :mynum :v 0 :compare (fn [self other] (case (type other) :number (cmp (self :v) other) :table (when (= (get other :type) :mynum) (cmp (self :v) (other :v)))))}) (let [n3 (table/setproto @{:v 3} mynum)] (assert (= 0 (compare 3 n3)) "compare num to object (1)") (assert (= -1 (compare n3 4)) "compare object to num (2)") (assert (= 1 (compare (table/setproto @{:v 4} mynum) n3)) "compare object to object") (assert (compare< 2 n3 4) "compare< poly") (assert (compare> 4 n3 2) "compare> poly") (assert (compare<= 2 3 n3 4) "compare<= poly") (assert (compare= 3 n3 (table/setproto @{:v 3} mynum)) "compare= poly") (assert (deep= (sorted @[4 5 n3 2] compare<) @[2 n3 4 5]) "polymorphic sort")) # Add any? predicate to core # 7478ad11 (assert (= nil (any? [])) "any? 1") (assert (= nil (any? [false nil])) "any? 2") (assert (= false (any? [nil false])) "any? 3") (assert (= 1 (any? [1])) "any? 4") (assert (nan? (any? [nil math/nan nil])) "any? 5") (assert (= true (any? [nil nil false nil nil true nil nil nil nil false :a nil])) "any? 6") (assert (= true (every? [])) "every? 1") (assert (= true (every? [1 true])) "every? 2") (assert (= 1 (every? [true 1])) "every? 3") (assert (= nil (every? [nil])) "every? 4") (assert (= 2 (every? [1 math/nan 2])) "every? 5") (assert (= false (every? [1 1 true 1 1 false 1 1 1 1 true :a nil])) "every? 6") # Some higher order functions and macros # 5e2de33 (def my-array @[1 2 3 4 5 6]) (assert (= (if-let [x (get my-array 5)] x) 6) "if-let 1") (assert (= (if-let [y (get @{} :key)] 10 nil) nil) "if-let 2") (assert (= (if-let [a my-array k (next a)] :t :f) :t) "if-let 3") (assert (= (if-let [a my-array k (next a 5)] :t :f) :f) "if-let 4") (assert (= (if-let [[a b] my-array] a) 1) "if-let 5") (assert (= (if-let [{:a a :b b} {:a 1 :b 2}] b) 2) "if-let 6") (assert (= (if-let [[a b] nil] :t :f) :f) "if-let 7") # #1191 (var cnt 0) (defmacro upcnt [] (++ cnt)) (assert (= (if-let [a true b true c true] nil (upcnt)) nil) "issue #1191") (assert (= cnt 1) "issue #1191") (assert (= 14 (sum (map inc @[1 2 3 4]))) "sum map") (def myfun (juxt + - * /)) (assert (= [2 -2 2 0.5] (myfun 2)) "juxt") # Case statements # 5249228 (assert (= :six (case (+ 1 2 3) 1 :one 2 :two 3 :three 4 :four 5 :five 6 :six 7 :seven 8 :eight 9 :nine)) "case macro") (assert (= 7 (case :a :b 5 :c 6 :u 10 7)) "case with default") # Testing the seq, tabseq, catseq, and loop macros # 547529e (def xs (apply tuple (seq [x :range [0 10] :when (even? x)] (tuple (/ x 2) x)))) (assert (= xs '((0 0) (1 2) (2 4) (3 6) (4 8))) "seq macro 1") # 624be87c9 (def xs (apply tuple (seq [x :down [8 -2] :when (even? x)] (tuple (/ x 2) x)))) (assert (= xs '((4 8) (3 6) (2 4) (1 2) (0 0))) "seq macro 2") # Looping idea # 45f8db0 (def xs (seq [x :in [-1 0 1] y :in [-1 0 1] :when (not= x y 0)] (tuple x y))) (def txs (apply tuple xs)) (assert (= txs [[-1 -1] [-1 0] [-1 1] [0 -1] [0 1] [1 -1] [1 0] [1 1]]) "nested seq") # :unless modifier (assert (deep= (seq [i :range [0 10] :unless (odd? i)] i) @[0 2 4 6 8]) ":unless modifier") # 515891b03 (assert (deep= (tabseq [i :in (range 3)] i (* 3 i)) @{0 0 1 3 2 6})) (assert (deep= (tabseq [i :in (range 3)] i) @{})) # ccd874fe4 (def xs (catseq [x :range [0 3]] [x x])) (assert (deep= xs @[0 0 1 1 2 2]) "catseq") # :range-to and :down-to # e0c9910d8 (assert (deep= (seq [x :range-to [0 10]] x) (seq [x :range [0 11]] x)) "loop :range-to") (assert (deep= (seq [x :down-to [10 0]] x) (seq [x :down [10 -1]] x)) "loop :down-to") # one-term :range forms (assert (deep= (seq [x :range [10]] x) (seq [x :range [0 10]] x)) "one-term :range") (assert (deep= (seq [x :down [10]] x) (seq [x :down [10 0]] x)) "one-term :down") # 7880d7320 (def res @{}) (loop [[k v] :pairs @{1 2 3 4 5 6}] (put res k v)) (assert (and (= (get res 1) 2) (= (get res 3) 4) (= (get res 5) 6)) "loop :pairs") # Issue #428 # 08a3687eb (var result nil) (defn f [] (yield {:a :ok})) (assert-no-error "issue 428 1" (loop [{:a x} :in (fiber/new f)] (set result x))) (assert (= result :ok) "issue 428 2") # Generators # 184fe31e0 (def gen (generate [x :range [0 100] :when (pos? (% x 4))] x)) (var gencount 0) (loop [x :in gen] (++ gencount) (assert (pos? (% x 4)) "generate in loop")) (assert (= gencount 75) "generate loop count") # more loop checks (assert (deep= (seq [i :range [0 10]] i) @[0 1 2 3 4 5 6 7 8 9]) "seq 1") (assert (deep= (seq [i :range [0 10 2]] i) @[0 2 4 6 8]) "seq 2") (assert (deep= (seq [i :range [10]] i) @[0 1 2 3 4 5 6 7 8 9]) "seq 3") (assert (deep= (seq [i :range-to [10]] i) @[0 1 2 3 4 5 6 7 8 9 10]) "seq 4") (def gen (generate [x :range-to [0 nil 2]] x)) (assert (deep= (take 5 gen) @[0 2 4 6 8]) "generate nil limit") (def gen (generate [x :range [0 nil 2]] x)) (assert (deep= (take 5 gen) @[0 2 4 6 8]) "generate nil limit 2") # Even and odd # ff163a5ae (assert (odd? 9) "odd? 1") (assert (odd? -9) "odd? 2") (assert (not (odd? 10)) "odd? 3") (assert (not (odd? 0)) "odd? 4") (assert (not (odd? -10)) "odd? 5") (assert (not (odd? 1.1)) "odd? 6") (assert (not (odd? -0.1)) "odd? 7") (assert (not (odd? -1.1)) "odd? 8") (assert (not (odd? -1.6)) "odd? 9") (assert (even? 10) "even? 1") (assert (even? -10) "even? 2") (assert (even? 0) "even? 3") (assert (not (even? 9)) "even? 4") (assert (not (even? -9)) "even? 5") (assert (not (even? 0.1)) "even? 6") (assert (not (even? -0.1)) "even? 7") (assert (not (even? -10.1)) "even? 8") (assert (not (even? -10.6)) "even? 9") # Map arities # 25ded775a (assert (deep= (map inc [1 2 3]) @[2 3 4])) (assert (deep= (map + [1 2 3] [10 20 30]) @[11 22 33])) (assert (deep= (map + [1 2 3] [10 20 30] [100 200 300]) @[111 222 333])) (assert (deep= (map + [1 2 3] [10 20 30] [100 200 300] [1000 2000 3000]) @[1111 2222 3333])) (assert (deep= (map + [1 2 3] [10 20 30] [100 200 300] [1000 2000 3000] [10000 20000 30000]) @[11111 22222 33333])) # 77e62a2 (assert (deep= (map + [1 2 3] [10 20 30] [100 200 300] [1000 2000 3000] [10000 20000 30000] [100000 200000 300000]) @[111111 222222 333333])) # Mapping uses the shortest sequence # a69799aa4 (assert (deep= (map + [1 2 3 4] [10 20 30]) @[11 22 33])) (assert (deep= (map + [1 2 3 4] [10 20 30] [100 200]) @[111 222])) (assert (deep= (map + [1 2 3 4] [10 20 30] [100 200] [1000]) @[1111])) # 77e62a2 (assert (deep= (map + [1 2 3 4] [10 20 30] [100 200] [1000] []) @[])) # Variadic arguments to map-like functions # 77e62a2 (assert (deep= (mapcat tuple [1 2 3 4] [5 6 7 8]) @[1 5 2 6 3 7 4 8])) (assert (deep= (keep |(if (> $1 0) (/ $0 $1)) [1 2 3 4 5] [1 2 1 0 1]) @[1 1 3 5])) (assert (= (count = [1 3 2 4 3 5 4 2 1] [1 2 3 4 5 4 3 2 1]) 4)) (assert (= (some not= (range 5) (range 5)) nil)) (assert (= (some = [1 2 3 4 5] [5 4 3 2 1]) true)) (assert (= (all = (range 5) (range 5)) true)) (assert (= (all not= [1 2 3 4 5] [5 4 3 2 1]) false)) # 4194374 (assert (= false (deep-not= [1] [1])) "issue #1149") # Merge sort # f5b29b8 # Imperative (and verbose) merge sort merge (defn merge-sort [xs ys] (def ret @[]) (def xlen (length xs)) (def ylen (length ys)) (var i 0) (var j 0) # Main merge (while (if (< i xlen) (< j ylen)) (def xi (get xs i)) (def yj (get ys j)) (if (< xi yj) (do (array/push ret xi) (set i (+ i 1))) (do (array/push ret yj) (set j (+ j 1))))) # Push rest of xs (while (< i xlen) (def xi (get xs i)) (array/push ret xi) (set i (+ i 1))) # Push rest of ys (while (< j ylen) (def yj (get ys j)) (array/push ret yj) (set j (+ j 1))) ret) (assert (apply <= (merge-sort @[1 3 5] @[2 4 6])) "merge sort merge 1") (assert (apply <= (merge-sort @[1 2 3] @[4 5 6])) "merge sort merge 2") (assert (apply <= (merge-sort @[1 3 5] @[2 4 6 6 6 9])) "merge sort merge 3") (assert (apply <= (merge-sort '(1 3 5) @[2 4 6 6 6 9])) "merge sort merge 4") (assert (deep= @[1 2 3 4 5] (sort @[5 3 4 1 2])) "sort 1") (assert (deep= @[{:a 1} {:a 4} {:a 7}] (sort-by |($ :a) @[{:a 4} {:a 7} {:a 1}])) "sort 2") (assert (deep= @[1 2 3 4 5] (sorted [5 3 4 1 2])) "sort 3") (assert (deep= @[{:a 1} {:a 4} {:a 7}] (sorted-by |($ :a) [{:a 4} {:a 7} {:a 1}])) "sort 4") # Sort function # 2ca9300bf (assert (deep= (range 99) (sort (mapcat (fn [[x y z]] [z y x]) (partition 3 (range 99))))) "sort 5") (assert (<= ;(sort (map (fn [x] (math/random)) (range 1000)))) "sort 6") # #1283 (assert (deep= (partition 2 (generate [ i :in [:a :b :c :d :e]] i)) '@[(:a :b) (:c :d) (:e)])) (assert (= (mean (generate [i :in [2 3 5 7 11]] i)) 5.6)) # And and or # c16a9d846 (assert (= (and true true) true) "and true true") (assert (= (and true false) false) "and true false") (assert (= (and false true) false) "and false true") (assert (= (and true true true) true) "and true true true") (assert (= (and 0 1 2) 2) "and 0 1 2") (assert (= (and 0 1 nil) nil) "and 0 1 nil") (assert (= (and 1) 1) "and 1") (assert (= (and) true) "and with no arguments") (assert (= (and 1 true) true) "and with trailing true") (assert (= (and 1 true 2) 2) "and with internal true") (assert (= (or true true) true) "or true true") (assert (= (or true false) true) "or true false") (assert (= (or false true) true) "or false true") (assert (= (or false false) false) "or false true") (assert (= (or true true false) true) "or true true false") (assert (= (or 0 1 2) 0) "or 0 1 2") (assert (= (or nil 1 2) 1) "or nil 1 2") (assert (= (or 1) 1) "or 1") (assert (= (or) nil) "or with no arguments") # And/or checks # 6123c41f1 (assert (= false (and false false)) "and 1") (assert (= false (or false false)) "or 1") # 11cd1279d (assert (deep= @{:a 1 :b 2 :c 3} (zipcoll '[:a :b :c] '[1 2 3])) "zipcoll") # bc8be266f (def- a 100) (assert (= a 100) "def-") # bc8be266f (assert (= :first (match @[1 3 5] @[x y z] :first :second)) "match 1") (def val1 :avalue) (assert (= :second (match val1 @[x y z] :first :avalue :second :third)) "match 2") (assert (= 100 (match @[50 40] @[x x] (* x 3) @[x y] (+ x y 10) 0)) "match 3") # Match checks # 47e8f669f (assert (= :hi (match nil nil :hi)) "match 1") (assert (= :hi (match {:a :hi} {:a a} a)) "match 2") (assert (= nil (match {:a :hi} {:a a :b b} a)) "match 3") (assert (= nil (match [1 2] [a b c] a)) "match 4") (assert (= 2 (match [1 2] [a b] b)) "match 5") # db631097b (assert (= [2 :a :b] (match [1 2 :a :b] [o & rest] rest)) "match 6") (assert (= [] (match @[:a] @[x & r] r :fallback)) "match 7") (assert (= :fallback (match @[1] @[x y & r] r :fallback)) "match 8") (assert (= [1 2 3 4] (match @[1 2 3 4] @[x y z & r] [x y z ;r] :fallback)) "match 9") # Test cases for #293 # d3b9b8d45 (assert (= :yes (match [1 2 3] [_ a _] :yes :no)) "match wildcard 1") (assert (= :no (match [1 2 3] [__ a __] :yes :no)) "match wildcard 2") (assert (= :yes (match [1 2 [1 2 3]] [_ a [_ _ _]] :yes :no)) "match wildcard 3") (assert (= :yes (match [1 2 3] (_ (even? 2)) :yes :no)) "match wildcard 4") (assert (= :yes (match {:a 1} {:a _} :yes :no)) "match wildcard 5") (assert (= false (match {:a 1 :b 2 :c 3} {:a a :b _ :c _ :d _} :no {:a _ :b _ :c _} false :no)) "match wildcard 6") (assert (= nil (match {:a 1 :b 2 :c 3} {:a a :b _ :c _ :d _} :no {:a _ :b _ :c _} nil :no)) "match wildcard 7") # issue #529 - 602010600 (assert (= "t" (match [true nil] [true _] "t")) "match wildcard 8") # quoted match test # 425a0fcf0 (assert (= :yes (match 'john 'john :yes _ :nope)) "quoted literal match 1") (assert (= :nope (match 'john ''john :yes _ :nope)) "quoted literal match 2") # Some macros # 7880d7320 (assert (= 2 (if-not 1 3 2)) "if-not 1") (assert (= 3 (if-not false 3)) "if-not 2") (assert (= 3 (if-not nil 3 2)) "if-not 3") (assert (= nil (if-not true 3)) "if-not 4") (assert (= 4 (unless false (+ 1 2 3) 4)) "unless") # take # 18da183ef (assert (deep= (take 0 []) []) "take 1") (assert (deep= (take 10 []) []) "take 2") (assert (deep= (take 0 [1 2 3 4 5]) []) "take 3") (assert (deep= (take 10 [1 2 3]) [1 2 3]) "take 4") (assert (deep= (take -1 [:a :b :c]) [:c]) "take 5") # 34019222c (assert (deep= (take 3 (generate [x :in [1 2 3 4 5]] x)) @[1 2 3]) "take from fiber") # NB: repeatedly resuming a fiber created with `generate` includes a `nil` # as the final element. Thus a generate of 2 elements will create an array # of 3. (assert (= (length (take 4 (generate [x :in [1 2]] x))) 2) "take from short fiber") # take-until # 18da183ef (assert (deep= (take-until pos? @[]) []) "take-until 1") (assert (deep= (take-until pos? @[1 2 3]) []) "take-until 2") (assert (deep= (take-until pos? @[-1 -2 -3]) [-1 -2 -3]) "take-until 3") (assert (deep= (take-until pos? @[-1 -2 3]) [-1 -2]) "take-until 4") (assert (deep= (take-until pos? @[-1 1 -2]) [-1]) "take-until 5") (assert (deep= (take-until |(= $ 115) "books") "book") "take-until 6") (assert (deep= (take-until |(= $ 115) (generate [x :in "books"] x)) @[98 111 111 107]) "take-until from fiber") # take-while # 18da183ef (assert (deep= (take-while neg? @[]) []) "take-while 1") (assert (deep= (take-while neg? @[1 2 3]) []) "take-while 2") (assert (deep= (take-while neg? @[-1 -2 -3]) [-1 -2 -3]) "take-while 3") (assert (deep= (take-while neg? @[-1 -2 3]) [-1 -2]) "take-while 4") (assert (deep= (take-while neg? @[-1 1 -2]) [-1]) "take-while 5") (assert (deep= (take-while neg? (generate [x :in @[-1 1 -2]] x)) @[-1]) "take-while from fiber") # drop # 18da183ef (assert (deep= (drop 0 []) []) "drop 1") (assert (deep= (drop 10 []) []) "drop 2") (assert (deep= (drop 0 [1 2 3 4 5]) [1 2 3 4 5]) "drop 3") (assert (deep= (drop 10 [1 2 3]) []) "drop 4") (assert (deep= (drop -1 [1 2 3]) [1 2]) "drop 5") (assert (deep= (drop -10 [1 2 3]) []) "drop 6") (assert (deep= (drop 1 "abc") "bc") "drop 7") (assert (deep= (drop 10 "abc") "") "drop 8") (assert (deep= (drop -1 "abc") "ab") "drop 9") (assert (deep= (drop -10 "abc") "") "drop 10") # drop-until # 75dc08f (assert (deep= (drop-until pos? @[]) []) "drop-until 1") (assert (deep= (drop-until pos? @[1 2 3]) [1 2 3]) "drop-until 2") (assert (deep= (drop-until pos? @[-1 -2 -3]) []) "drop-until 3") (assert (deep= (drop-until pos? @[-1 -2 3]) [3]) "drop-until 4") (assert (deep= (drop-until pos? @[-1 1 -2]) [1 -2]) "drop-until 5") (assert (deep= (drop-until |(= $ 115) "books") "s") "drop-until 6") # take-drop symmetry #1178 (def items-list ['abcde :abcde "abcde" @"abcde" [1 2 3 4 5] @[1 2 3 4 5]]) (each items items-list (def len (length items)) (for i 0 (+ len 1) (assert (deep= (take i items) (drop (- i len) items)) (string/format "take-drop symmetry %q %d" items i)) (assert (deep= (take (- i) items) (drop (- len i) items)) (string/format "take-drop symmetry %q %d" items i)))) (defn squares [] (coro (var [a b] [0 1]) (forever (yield a) (+= a b) (+= b 2)))) (def sqr1 (squares)) (assert (deep= (take 10 sqr1) @[0 1 4 9 16 25 36 49 64 81])) (assert (deep= (take 1 sqr1) @[100]) "take fiber next value") (def sqr2 (drop 10 (squares))) (assert (deep= (take 1 sqr2) @[100]) "drop fiber next value") (def dict @{:a 1 :b 2 :c 3 :d 4 :e 5}) (def dict1 (take 2 dict)) (def dict2 (drop 2 dict)) (assert (= (length dict1) 2) "take dictionary") (assert (= (length dict2) 3) "drop dictionary") (assert (deep= (merge dict1 dict2) dict) "take-drop symmetry for dictionary") # Comment macro # issue #110 - 698e89aba (comment 1) (comment 1 2) (comment 1 2 3) (comment 1 2 3 4) # comp should be variadic # 5c83ebd75, 02ce3031 (assert (= 10 ((comp +) 1 2 3 4)) "variadic comp 1") (assert (= 11 ((comp inc +) 1 2 3 4)) "variadic comp 2") (assert (= 12 ((comp inc inc +) 1 2 3 4)) "variadic comp 3") (assert (= 13 ((comp inc inc inc +) 1 2 3 4)) "variadic comp 4") (assert (= 14 ((comp inc inc inc inc +) 1 2 3 4)) "variadic comp 5") (assert (= 15 ((comp inc inc inc inc inc +) 1 2 3 4)) "variadic comp 6") (assert (= 16 ((comp inc inc inc inc inc inc +) 1 2 3 4)) "variadic comp 7") # Function shorthand # 44e752d73 (assert (= (|(+ 1 2 3)) 6) "function shorthand 1") (assert (= (|(+ 1 2 3 $) 4) 10) "function shorthand 2") (assert (= (|(+ 1 2 3 $0) 4) 10) "function shorthand 3") (assert (= (|(+ $0 $0 $0 $0) 4) 16) "function shorthand 4") (assert (= (|(+ $ $ $ $) 4) 16) "function shorthand 5") (assert (= (|4) 4) "function shorthand 6") (assert (= (((|||4))) 4) "function shorthand 7") (assert (= (|(+ $1 $1 $1 $1) 2 4) 16) "function shorthand 8") (assert (= (|(+ $0 $1 $3 $2 $6) 0 1 2 3 4 5 6) 12) "function shorthand 9") # 5f5147652 (assert (= (|(+ $0 $99) ;(range 100)) 99) "function shorthand 10") # 655d4b3aa (defn idx= [x y] (= (tuple/slice x) (tuple/slice y))) # Simple take, drop, etc. tests. (assert (idx= (take 10 (range 100)) (range 10)) "take 10") (assert (idx= (drop 10 (range 100)) (range 10 100)) "drop 10") # with-vars # 6ceaf9d28 (var abc 123) (assert (= 356 (with-vars [abc 456] (- abc 100))) "with-vars 1") (assert-error "with-vars 2" (with-vars [abc 456] (error :oops))) (assert (= abc 123) "with-vars 3") # Top level unquote # 2487162cc (defn constantly [] (comptime (math/random))) (assert (= (constantly) (constantly)) "comptime 1") # issue #232 - b872ee024 (assert-error "arity issue in macro" (eval '(each []))) # c6b639b93 (assert-error "comptime issue" (eval '(comptime (error "oops")))) # 962cd7e5f (var counter 0) (when-with [x nil |$] (++ counter)) (when-with [x 10 |$] (+= counter 10)) (assert (= 10 counter) "when-with 1") (if-with [x nil |$] (++ counter) (+= counter 10)) (if-with [x true |$] (+= counter 20) (+= counter 30)) (assert (= 40 counter) "if-with 1") # a45509d28 (def a @[]) (eachk x [:a :b :c :d] (array/push a x)) (assert (deep= (range 4) a) "eachk 1") # issue 609 - 1fcaffe (with-dyns [:err @""] (tracev (def my-unique-var-name true)) (assert my-unique-var-name "tracev upscopes")) # Prompts and Labels # 59d288c (assert (= 10 (label a (for i 0 10 (if (= i 5) (return a 10))))) "label 1") (defn recur [lab x y] (when (= x y) (return lab :done)) (def res (label newlab (recur (or lab newlab) (+ x 1) y))) (if lab :oops res)) (assert (= :done (recur nil 0 10)) "label 2") (assert (= 10 (prompt :a (for i 0 10 (if (= i 5) (return :a 10))))) "prompt 1") (defn- inner-loop [i] (if (= i 5) (return :a 10))) (assert (= 10 (prompt :a (for i 0 10 (inner-loop i)))) "prompt 2") (defn- inner-loop2 [i] (try (if (= i 5) (error 10)) ([err] (return :a err)))) (assert (= 10 (prompt :a (for i 0 10 (inner-loop2 i)))) "prompt 3") # chr # issue 304 - 77343e02e (assert (= (chr "a") 97) "chr 1") # Reduce2 # 3eb0927a2 (assert (= (reduce + 0 (range 1 10)) (reduce2 + (range 10))) "reduce2 1") # 65379741f (assert (= (reduce * 1 (range 2 10)) (reduce2 * (range 1 10))) "reduce2 2") (assert (= nil (reduce2 * [])) "reduce2 3") # Accumulate # 3eb0927a2 (assert (deep= (accumulate + 0 (range 5)) @[0 1 3 6 10]) "accumulate 1") (assert (deep= (accumulate2 + (range 5)) @[0 1 3 6 10]) "accumulate2 1") # 65379741f (assert (deep= @[] (accumulate2 + [])) "accumulate2 2") (assert (deep= @[] (accumulate 0 + [])) "accumulate 2") # in vs get regression # issue #340 - b63a0796f (assert (nil? (first @"")) "in vs get 1") (assert (nil? (last @"")) "in vs get 1") # index-of # 259812314 (assert (= nil (index-of 10 [])) "index-of 1") (assert (= nil (index-of 10 [1 2 3])) "index-of 2") (assert (= 1 (index-of 2 [1 2 3])) "index-of 3") (assert (= 0 (index-of :a [:a :b :c])) "index-of 4") (assert (= nil (index-of :a {})) "index-of 5") (assert (= :a (index-of :A {:a :A :b :B})) "index-of 6") (assert (= :a (index-of :A @{:a :A :b :B})) "index-of 7") (assert (= 0 (index-of (chr "a") "abc")) "index-of 8") (assert (= nil (index-of (chr "a") "")) "index-of 9") (assert (= nil (index-of 10 @[])) "index-of 10") (assert (= nil (index-of 10 @[1 2 3])) "index-of 11") # e78a3d1 # NOTE: These is a motivation for the has-value? and has-key? functions below # returns false despite key present (assert (= false (index-of 8 {true 7 false 8})) "index-of corner key (false) 1") (assert (= false (index-of 8 @{false 8})) "index-of corner key (false) 2") # still returns null (assert (= nil (index-of 7 {false 8})) "index-of corner key (false) 3") # has-value? (assert (= false (has-value? [] "foo")) "has-value? 1") (assert (= true (has-value? [4 7 1 3] 4)) "has-value? 2") (assert (= false (has-value? [4 7 1 3] 22)) "has-value? 3") (assert (= false (has-value? @[1 2 3] 4)) "has-value? 4") (assert (= true (has-value? @[:a :b :c] :a)) "has-value? 5") (assert (= false (has-value? {} :foo)) "has-value? 6") (assert (= true (has-value? {:a :A :b :B} :A)) "has-value? 7") (assert (= true (has-value? {:a :A :b :B} :A)) "has-value? 7") (assert (= true (has-value? @{:a :A :b :B} :A)) "has-value? 8") (assert (= true (has-value? "abc" (chr "a"))) "has-value? 9") (assert (= false (has-value? "abc" "1")) "has-value? 10") # weird true/false corner cases, should align with "index-of corner # key {k}" cases (assert (= true (has-value? {true 7 false 8} 8)) "has-value? corner key (false) 1") (assert (= true (has-value? @{false 8} 8)) "has-value? corner key (false) 2") (assert (= false (has-value? {false 8} 7)) "has-value? corner key (false) 3") # has-key? (do (var test-has-key-auto 0) (defn test-has-key [col key expected &keys {:name name}] ``Test that has-key has the outcome `expected`, and that if the result is true, then ensure (in key) does not fail either`` (assert (boolean? expected)) (default name (string "has-key? " (++ test-has-key-auto))) (assert (= expected (has-key? col key)) name) (if # guaranteed by `has-key?` to never fail expected (in col key) # if `has-key?` is false, then `in` should fail (for indexed types) # # For dictionary types, it should return nil (let [[success retval] (protect (in col key))] (def should-succeed (dictionary? col)) (assert (= success should-succeed) (string/format "%s: expected (in col key) to %s, but got %q" name (if expected "succeed" "fail") retval))))) (test-has-key [] 0 false) # 1 (test-has-key [4 7 1 3] 2 true) # 2 (test-has-key [4 7 1 3] 22 false) # 3 (test-has-key @[1 2 3] 4 false) # 4 (test-has-key @[:a :b :c] 2 true) # 5 (test-has-key {} :foo false) # 6 (test-has-key {:a :A :b :B} :a true) # 7 (test-has-key {:a :A :b :B} :A false) # 8 (test-has-key @{:a :A :b :B} :a true) # 9 (test-has-key "abc" 1 true) # 10 (test-has-key "abc" 4 false) # 11 # weird true/false corner cases # # Tries to mimic the corresponding corner cases in has-value? and # index-of, but with keys/values inverted # # in the first two cases (truthy? (get val col)) would have given false # negatives (test-has-key {7 true 8 false} 8 true :name "has-key? corner value (false) 1") (test-has-key @{8 false} 8 true :name "has-key? corner value (false) 2") (test-has-key @{8 false} 7 false :name "has-key? corner value (false) 3")) # Regression # issue #463 - 7e7498350 (assert (= {:x 10} (|(let [x $] ~{:x ,x}) 10)) "issue 463") # macex testing # 7e7498350 (assert (deep= (macex1 '~{1 2 3 4}) '~{1 2 3 4}) "macex1 qq struct") (assert (deep= (macex1 '~@{1 2 3 4}) '~@{1 2 3 4}) "macex1 qq table") (assert (deep= (macex1 '~(1 2 3 4)) '~[1 2 3 4]) "macex1 qq tuple") (assert (= :brackets (tuple/type (1 (macex1 '~[1 2 3 4])))) "macex1 qq bracket tuple") (assert (deep= (macex1 '~@[1 2 3 4 ,blah]) '~@[1 2 3 4 ,blah]) "macex1 qq array") # Sourcemaps in threading macros # b6175e429 (defn check-threading [macro expansion] (def expanded (macex1 (tuple macro 0 '(x) '(y)))) (assert (= expanded expansion) (string macro " expansion value")) (def smap-x (tuple/sourcemap (get expanded 1))) (def smap-y (tuple/sourcemap expanded)) (def line first) (defn column [t] (t 1)) (assert (not= smap-x [-1 -1]) (string macro " x sourcemap existence")) (assert (not= smap-y [-1 -1]) (string macro " y sourcemap existence")) (assert (or (< (line smap-x) (line smap-y)) (and (= (line smap-x) (line smap-y)) (< (column smap-x) (column smap-y)))) (string macro " relation between x and y sourcemap"))) (check-threading '-> '(y (x 0))) (check-threading '->> '(y (x 0))) # keep-syntax # b6175e429 (let [brak '[1 2 3] par '(1 2 3)] (tuple/setmap brak 2 1) (assert (deep= (keep-syntax brak @[1 2 3]) @[1 2 3]) "keep-syntax brackets ignore array") (assert (= (keep-syntax! brak @[1 2 3]) '[1 2 3]) "keep-syntax! brackets replace array") (assert (= (keep-syntax! par (map inc @[1 2 3])) '(2 3 4)) "keep-syntax! parens coerce array") (assert (not= (keep-syntax! brak @[1 2 3]) '(1 2 3)) "keep-syntax! brackets not parens") (assert (not= (keep-syntax! par @[1 2 3]) '[1 2 3]) "keep-syntax! parens not brackets") (assert (= (tuple/sourcemap brak) (tuple/sourcemap (keep-syntax! brak @[1 2 3]))) "keep-syntax! brackets source map") (keep-syntax par brak) (assert (not= (tuple/sourcemap brak) (tuple/sourcemap par)) "keep-syntax no mutate") (assert (= (keep-syntax 1 brak) brak) "keep-syntax brackets ignore type")) # Curenv # 28439d822, f7c556e (assert (= (curenv) (curenv 0)) "curenv 1") (assert (= (table/getproto (curenv)) (curenv 1)) "curenv 2") (assert (= nil (curenv 1000000)) "curenv 3") (assert (= root-env (curenv 1)) "curenv 4") # Import macro test # a31e079f9 (assert-no-error "import macro 1" (macex '(import a :as b :fresh maybe))) (assert (deep= ~(,import* "a" :as "b" :fresh maybe) (macex '(import a :as b :fresh maybe))) "import macro 2") # 2af3f21d (assert-error "import macro 2" (macex '(import a :fresh))) (assert-error "import macro 3" (macex '(import a :as b :fresh))) (assert-error "import macro 4" (macex '(import b "notakeyword" value))) (assert (deep= ~(,import* "a" :fresh nil) (macex '(import a :fresh nil))) "import macro 5") # #477 walk preserving bracket type # 0a1d902f4 (assert (= :brackets (tuple/type (postwalk identity '[]))) "walk square brackets 1") (assert (= :brackets (tuple/type (walk identity '[]))) "walk square brackets 2") # Issue #751 # 547fda6a4 (def t {:side false}) (assert (nil? (get-in t [:side :note])) "get-in with false value") (assert (= (get-in t [:side :note] "dflt") "dflt") "get-in with false value and default") # Evaluate stream with `dofile` # 9cc4e4812 (def [r w] (os/pipe)) (:write w "(setdyn :x 10)") (:close w) (def stream-env (dofile r)) (assert (= (stream-env :x) 10) "dofile stream 1") # Test thaw and freeze # 9cc0645a1 (def table-to-freeze @{:c 22 :b [1 2 3 4] :d @"test" :e "test2"}) (def table-to-freeze-with-inline-proto @{:a @[1 2 3] :b @[1 2 3 4] :c 22 :d @"test" :e @"test2"}) (def struct-to-thaw (struct/with-proto {:a [1 2 3]} :c 22 :b [1 2 3 4] :d "test" :e "test2")) (table/setproto table-to-freeze @{:a @[1 2 3]}) (assert (deep= struct-to-thaw (freeze table-to-freeze))) (assert (deep= table-to-freeze-with-inline-proto (thaw table-to-freeze))) (assert (deep= table-to-freeze-with-inline-proto (thaw struct-to-thaw))) # Check that freezing mutable keys is deterministic # for issue #1535 (def hashes @{}) (repeat 200 (def x (freeze {@"" 1 @"" 2 @"" 3 @"" 4 @"" 5})) (put hashes (hash x) true)) (assert (= 1 (length hashes)) "freeze mutable keys is deterministic") # Make sure Carriage Returns don't end up in doc strings # e528b86 (assert (not (string/find "\r" (get ((fiber/getenv (fiber/current)) 'cond) :doc ""))) "no \\r in doc strings") # cff718f37 (var counter 0) (def thunk (delay (++ counter))) (assert (= (thunk) 1) "delay 1") (assert (= counter 1) "delay 2") (assert (= (thunk) 1) "delay 3") (assert (= counter 1) "delay 4") # maclintf (def env (table/clone (curenv))) ((compile '(defmacro foo [] (maclintf :strict "oops")) env :anonymous)) (def lints @[]) (compile (tuple/setmap '(foo) 1 2) env :anonymous lints) (assert (deep= lints @[[:strict 1 2 "oops"]]) "maclintf 1") (def env (table/clone (curenv))) ((compile '(defmacro foo [& body] (maclintf :strict "foo-oops") ~(do ,;body)) env :anonymous)) ((compile '(defmacro bar [] (maclintf :strict "bar-oops")) env :anonymous)) (def lints @[]) # Compile (foo (bar)), but with explicit source map values (def bar-invoke (tuple/setmap '(bar) 3 4)) (compile (tuple/setmap ~(foo ,bar-invoke) 1 2) env :anonymous lints) (assert (deep= lints @[[:strict 1 2 "foo-oops"] [:strict 3 4 "bar-oops"]]) "maclintf 2") # Bad bytecode wrt. using result from break expression (defn bytecode-roundtrip [f] (assert-no-error "bytecode round-trip" (unmarshal (marshal f make-image-dict)))) (defn case-1 [&] (def x (break 1))) (bytecode-roundtrip case-1) (defn foo [&]) (defn case-2 [&] (foo (break (foo))) (foo)) (bytecode-roundtrip case-2) (defn case-3 [&] (def x (break (do (foo))))) (bytecode-roundtrip case-3) (defn case-4 [&] (def x (break (break (foo))))) (bytecode-roundtrip case-4) (defn case-4 [&] (def x (break (break (break))))) (bytecode-roundtrip case-4) (defn case-5 [] (def foo (fn [one two] one)) (foo 100 200)) (bytecode-roundtrip case-5) # Debug bytecode of these functions # (pp (disasm case-1)) # (pp (disasm case-2)) # (pp (disasm case-3)) # Regression #1330 (defn regress-1330 [&] (def a [1 2 3]) (def b [;a]) (identity a)) (assert (= [1 2 3] (regress-1330)) "regression 1330") # Issue 1341 (assert (= () '() (macex '())) "macex ()") (assert (= '[] (macex '[])) "macex []") (assert (= :a (with-env @{:b :a} (dyn :b))) "with-env dyn") (assert-error "unknown symbol +" (with-env @{} (eval '(+ 1 2)))) (setdyn *debug* true) (def source '(defn a [x] (+ x x))) (eval source) (assert (= 20 (a 10))) (assert (deep= (get (dyn 'a) :source-form) source)) (setdyn *debug* nil) # issue #1516 (assert-error "assertf 1 argument" (macex '(assertf true))) (assert (assertf true "fun message") "assertf 2 arguments") (assert (assertf true "%s message" "mystery") "assertf 3 arguments") (assert (assertf (not nil) "%s message" "ordinary") "assertf not nil") (assert-error "assertf error 2" (assertf false "fun message")) (assert-error "assertf error 3" (assertf false "%s message" "mystery")) (assert-error "assertf error 4" (assertf nil "%s %s" "alice" "bob")) # issue #1535 (loop [i :range [1 1000]] (assert (deep-not= @{:key1 "value1" @"key" "value2"} @{:key1 "value1" @"key" "value2"}) "deep= mutable keys")) (assert (deep-not= {"abc" 123} {@"abc" 123}) "deep= mutable keys vs immutable key") (assert (deep-not= {@"" 1 @"" 2 @"" 3} {@"" 1 @"" 2 @"" 3}) "deep= duplicate mutable keys") (assert (deep-not= {@"" @"" @"" @"" @"" 3} {@"" @"" @"" @"" @"" 3}) "deep= duplicate mutable keys 2") (assert (deep-not= {@[] @"" @[] @"" @[] 3} {@[] @"" @[] @"" @[] 3}) "deep= duplicate mutable keys 3") (assert (deep-not= {@{} @"" @{} @"" @{} 3} {@{} @"" @{} @"" @{} 3}) "deep= duplicate mutable keys 4") (assert (deep-not= @{:key1 "value1" @"key2" @"value2"} @{:key1 "value1" @"key2" "value2"}) "deep= mutable keys") (assert (deep-not= @{:key1 "value1" [@"key2"] @"value2"} @{:key1 "value1" [@"key2"] @"value2"}) "deep= mutable keys") # different try overloads (assert (= (try (error :error) ([] :caught)) :caught)) (assert (= (try (error :error) ([e] e)) :error)) (assert (= (try (error :error) ([e fib] [e (fiber? fib)])) [:error true])) # regression test for #1659 (assert (= (try (error :error) ([_ _] :caught)) :caught)) (end-suite) janet-1.41.2/test/suite-buffer.janet000066400000000000000000000167261514534607600173310ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Buffer blitting # 16ebb1118 (def b (buffer/new-filled 100)) (buffer/bit-set b 100) (buffer/bit-clear b 100) (assert (zero? (sum b)) "buffer bit set and clear") (assert (= false (buffer/bit b 101)) "bit get false") (buffer/bit-toggle b 101) (assert (= true (buffer/bit b 101)) "bit get true") (assert (= 32 (sum b)) "buffer bit set and clear") (assert-error "invalid bit index 1000" (buffer/bit-toggle b 1000)) (def b2 @"hello world") (buffer/blit b2 "joyto ") (assert (= (string b2) "joyto world") "buffer/blit 1") (buffer/blit b2 "joyto" 6) (assert (= (string b2) "joyto joyto") "buffer/blit 2") (buffer/blit b2 "abcdefg" 5 6) (assert (= (string b2) "joytogjoyto") "buffer/blit 3") # buffer/push (assert (deep= (buffer/push @"AA" @"BB") @"AABB") "buffer/push buffer") (assert (deep= (buffer/push @"AA" 66 66) @"AABB") "buffer/push int") (def b @"AA") (assert (deep= (buffer/push b b) @"AAAA") "buffer/push buffer self") # buffer/push-byte (assert (deep= (buffer/push-byte @"AA" 66) @"AAB") "buffer/push-byte") (assert-error "bad slot #1, expected 32 bit signed integer" (buffer/push-byte @"AA" :flap)) # Buffer push word # e755f9830 (def b3 @"") (buffer/push-word b3 0xFF 0x11) (assert (= 8 (length b3)) "buffer/push-word 1") (assert (= "\xFF\0\0\0\x11\0\0\0" (string b3)) "buffer/push-word 2") (buffer/clear b3) (buffer/push-word b3 0xFFFFFFFF 0x1100) (assert (= 8 (length b3)) "buffer/push-word 3") (assert (= "\xFF\xFF\xFF\xFF\0\x11\0\0" (string b3)) "buffer/push-word 4") (assert-error "cannot convert 0.5 to machine word" (buffer/push-word @"" 0.5)) # Buffer push string # 175925207 (def b4 (buffer/new-filled 10 0)) (buffer/push-string b4 b4) (assert (= "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" (string b4)) "buffer/push-buffer 1") (def b5 @"123") (buffer/push-string b5 "456" @"789") (assert (= "123456789" (string b5)) "buffer/push-buffer 2") (def buffer-uint16-be @"") (buffer/push-uint16 buffer-uint16-be :be 0x0102) (assert (= "\x01\x02" (string buffer-uint16-be)) "buffer/push-uint16 big endian") (def buffer-uint16-le @"") (buffer/push-uint16 buffer-uint16-le :le 0x0102) (assert (= "\x02\x01" (string buffer-uint16-le)) "buffer/push-uint16 little endian") (def buffer-uint16-max @"") (buffer/push-uint16 buffer-uint16-max :be 0xFFFF) (assert (= "\xff\xff" (string buffer-uint16-max)) "buffer/push-uint16 max") (assert-error "too large" (buffer/push-uint16 @"" 0x1FFFF)) (assert-error "too small" (buffer/push-uint16 @"" -0x1)) (def buffer-uint32-be @"") (buffer/push-uint32 buffer-uint32-be :be 0x01020304) (assert (= "\x01\x02\x03\x04" (string buffer-uint32-be)) "buffer/push-uint32 big endian") (def buffer-uint32-le @"") (buffer/push-uint32 buffer-uint32-le :le 0x01020304) (assert (= "\x04\x03\x02\x01" (string buffer-uint32-le)) "buffer/push-uint32 little endian") (def buffer-uint32-max @"") (buffer/push-uint32 buffer-uint32-max :be 0xFFFFFFFF) (assert (= "\xff\xff\xff\xff" (string buffer-uint32-max)) "buffer/push-uint32 max") (def buffer-float32-be @"") (buffer/push-float32 buffer-float32-be :be 1.234) (assert (= "\x3f\x9d\xf3\xb6" (string buffer-float32-be)) "buffer/push-float32 big endian") (def buffer-float32-le @"") (buffer/push-float32 buffer-float32-le :le 1.234) (assert (= "\xb6\xf3\x9d\x3f" (string buffer-float32-le)) "buffer/push-float32 little endian") (def buffer-float64-be @"") (buffer/push-float64 buffer-float64-be :be 1.234) (assert (= "\x3f\xf3\xbe\x76\xc8\xb4\x39\x58" (string buffer-float64-be)) "buffer/push-float64 big endian") (def buffer-float64-le @"") (buffer/push-float64 buffer-float64-le :le 1.234) (assert (= "\x58\x39\xb4\xc8\x76\xbe\xf3\x3f" (string buffer-float64-le)) "buffer/push-float64 little endian") # Buffer from bytes (assert (deep= @"" (buffer/from-bytes)) "buffer/from-bytes 1") (assert (deep= @"ABC" (buffer/from-bytes 65 66 67)) "buffer/from-bytes 2") (assert (deep= @"0123456789" (buffer/from-bytes ;(range 48 58))) "buffer/from-bytes 3") (assert (= 0 (length (buffer/from-bytes))) "buffer/from-bytes 4") (assert (= 5 (length (buffer/from-bytes ;(range 5)))) "buffer/from-bytes 5") (assert-error "bad slot #1, expected 32 bit signed integer" (buffer/from-bytes :abc)) # some tests for buffer/format # 029394d (assert (= (string (buffer/format @"" "pi = %6.3f" math/pi)) "pi = 3.142") "%6.3f") (assert (= (string (buffer/format @"" "pi = %+6.3f" math/pi)) "pi = +3.142") "%6.3f") (assert (= (string (buffer/format @"" "pi = %40.20g" math/pi)) "pi = 3.141592653589793116") "%6.3f") (assert (= (string (buffer/format @"" "🐼 = %6.3f" math/pi)) "🐼 = 3.142") "UTF-8") (assert (= (string (buffer/format @"" "π = %.8g" math/pi)) "π = 3.1415927") "π") (assert (= (string (buffer/format @"" "\xCF\x80 = %.8g" math/pi)) "\xCF\x80 = 3.1415927") "\xCF\x80") # Regression #301 # a3d4ecddb (def b (buffer/new-filled 128 0x78)) (assert (= 38 (length (buffer/blit @"" b -1 90))) "buffer/blit 1") (def a @"abcdefghijklm") (assert (deep= @"abcde" (buffer/blit @"" a -1 0 5)) "buffer/blit 2") (assert (deep= @"bcde" (buffer/blit @"" a -1 1 5)) "buffer/blit 3") (assert (deep= @"cde" (buffer/blit @"" a -1 2 5)) "buffer/blit 4") (assert (deep= @"de" (buffer/blit @"" a -1 3 5)) "buffer/blit 5") (assert (deep= @"de" (buffer/blit @"" a nil 3 5)) "buffer/blit 6") # buffer/push-at # c55d93512 (assert (deep= @"abc456" (buffer/push-at @"abc123" 3 "456")) "buffer/push-at 1") (assert (deep= @"abc456789" (buffer/push-at @"abc123" 3 "456789")) "buffer/push-at 2") (assert (deep= @"abc423" (buffer/push-at @"abc123" 3 "4")) "buffer/push-at 3") # buffer/format-at (def start-buf (buffer/new-filled 100 (chr "x"))) (buffer/format-at start-buf 50 "aa%dbb" 32) (assert (= (string start-buf) (string (string/repeat "x" 50) "aa32bb" (string/repeat "x" 44))) "buffer/format-at 1") (assert (deep= (buffer/format @"" "%j" [1 2 3 :a :b :c]) (buffer/format-at @"" 0 "%j" [1 2 3 :a :b :c])) "buffer/format-at empty buffer") (def buf @"xxxyyy") (buffer/format-at buf -4 "xxx") (assert (= (string buf) "xxxxxx") "buffer/format-at negative index") (assert-error "expected index at to be in range [0, 0), got 1" (buffer/format-at @"" 1 "abc")) # Regression 1714 (repeat 10 (assert (deep= (put @"" 100 10) (put (buffer (string/repeat "\0" 101)) 100 10)) "regression 1714") (assert (deep= (put @"" 200 10) (put (buffer (string/repeat "\0" 201)) 200 10)) "regression 1714")) (end-suite) janet-1.41.2/test/suite-bundle.janet000066400000000000000000000134051514534607600173200ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) (assert true) # smoke test # Testing here is stateful since we are manipulating the filesystem. # Copy since not exposed in boot.janet (defn- bundle-rpath [path] (string/replace-all "\\" "/" (os/realpath path))) # Test mkdir -> rmdir (assert (os/mkdir "tempdir123")) (rmrf "tempdir123") # Setup a temporary syspath for manipultation (math/seedrandom (os/cryptorand 16)) (def syspath (randdir)) (rmrf syspath) (assert (os/mkdir syspath)) (put root-env *syspath* (bundle-rpath syspath)) (unless (os/getenv "VERBOSE") (setdyn *out* @"")) (assert (empty? (bundle/list)) "initial bundle/list") (assert (empty? (bundle/topolist)) "initial bundle/topolist") # Try (and fail) to install sample-bundle (missing deps) (assert-error "missing dependencies sample-dep1, sample-dep2" (bundle/install "./examples/sample-bundle")) (assert (empty? (bundle/list))) # Install deps (dep1 as :auto-remove) (assert-no-error "sample-dep2" (bundle/install "./examples/sample-dep2")) (assert (= 1 (length (bundle/list)))) (assert-no-error "sample-dep1" (bundle/install "./examples/sample-dep1")) (assert (= 2 (length (bundle/list)))) (assert-no-error "sample-dep2 reinstall" (bundle/reinstall "sample-dep2")) (assert-no-error "sample-dep1 reinstall" (bundle/reinstall "sample-dep1" :auto-remove true)) (assert (= 2 (length (bundle/list))) "bundles are listed correctly 1") (assert (= 2 (length (bundle/topolist))) "bundles are listed correctly 2") # Now install sample-bundle (assert-no-error "sample-bundle install" (bundle/install "./examples/sample-bundle")) (assert-error "" (bundle/install "./examples/sample-dep11111")) (assert (= 3 (length (bundle/list))) "bundles are listed correctly 3") (assert (= 3 (length (bundle/topolist))) "bundles are listed correctly 4") # Check topolist has not bad order (def tlist (bundle/topolist)) (assert (> (index-of "sample-bundle" tlist) (index-of "sample-dep2" tlist)) "topolist 1") (assert (> (index-of "sample-bundle" tlist) (index-of "sample-dep1" tlist)) "topolist 2") (assert (> (index-of "sample-dep1" tlist) (index-of "sample-dep2" tlist)) "topolist 3") # Prune should do nothing (assert-no-error "first prune" (bundle/prune)) (assert (= 3 (length (bundle/list))) "bundles are listed correctly 3") (assert (= 3 (length (bundle/topolist))) "bundles are listed correctly 4") # Check that we can import the main dependency (import mymod) (assert (= 288 (mymod/myfn 12)) "using sample-bundle") # Manual uninstall of dep1 and dep2 shouldn't work either since that would break dependencies (assert-error "cannot uninstall sample-dep1, breaks dependent bundles @[\"sample-bundle\"]" (bundle/uninstall "sample-dep1")) # Check bundle file aliases (assert-no-error "sample-bundle-aliases install" (bundle/install "./examples/sample-bundle-aliases")) (assert (= 4 (length (bundle/list))) "bundles are listed correctly 5") (assert-no-error "import aliases" (import aliases-mod)) (assert (deep= (range 12) (aliases-mod/fun 12)) "using sample-bundle-aliases") (assert-no-error "aliases uninstall" (bundle/uninstall "sample-bundle-aliases")) # Now re-install sample-bundle as auto-remove (assert-no-error "sample-bundle install" (bundle/reinstall "sample-bundle" :auto-remove true)) # Reinstallation should also work without being concerned about breaking dependencies (assert-no-error "reinstall dep" (bundle/reinstall "sample-dep2")) # Now prune should get rid of everything except sample-dep2 (assert-no-error "second prune" (bundle/prune)) # Now check that we exactly one package left, which is dep2 (assert (= 1 (length (bundle/list))) "bundles are listed correctly 5") (assert (= 1 (length (bundle/topolist))) "bundles are listed correctly 6") # Which we can uninstall manually (assert-no-error "uninstall dep2" (bundle/uninstall "sample-dep2")) # Now check bundle listing is again empty (assert (= 0 (length (bundle/list))) "bundles are listed correctly 7") (assert (= 0 (length (bundle/topolist))) "bundles are listed correctly 8") # Try installing a bundle that is missing bundle script (assert-error-value "bundle missing bundle script" "bundle must contain bundle.janet or bundle/init.janet" (bundle/install "./examples/sample-bad-bundle1")) (assert (= 0 (length (bundle/list))) "check failure 0") (assert (= 0 (length (bundle/topolist))) "check failure 1") # Try installing a bundle that fails check (assert-error-value "bundle check hook fails" "Check failed!" (bundle/install "./examples/sample-bad-bundle2" :check true)) (assert (= 0 (length (bundle/list))) "check failure 0") (assert (= 0 (length (bundle/topolist))) "check failure 1") (rmrf syspath) (end-suite) janet-1.41.2/test/suite-capi.janet000066400000000000000000000035121514534607600167610ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Tuple types # c6edf03ae (assert (= (tuple/type '(1 2 3)) :parens) "normal tuple") (assert (= (tuple/type [1 2 3]) :parens) "normal tuple 1") (assert (= (tuple/type '[1 2 3]) :brackets) "bracketed tuple 2") (assert (= (tuple/type (-> '(1 2 3) marshal unmarshal)) :parens) "normal tuple marshalled/unmarshalled") (assert (= (tuple/type (-> '[1 2 3] marshal unmarshal)) :brackets) "normal tuple marshalled/unmarshalled") # Dynamic bindings # 7918add47, 513d551d (setdyn :a 10) (assert (= 40 (with-dyns [:a 25 :b 15] (+ (dyn :a) (dyn :b)))) "dyn usage 1") (assert (= 10 (dyn :a)) "dyn usage 2") (assert (= nil (dyn :b)) "dyn usage 3") (setdyn :a 100) (assert (= 100 (dyn :a)) "dyn usage 4") (end-suite) janet-1.41.2/test/suite-cfuns.janet000066400000000000000000000025231514534607600171640ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Inline 3 argument get # a1ea62a (assert (= 10 (do (var a 10) (set a (get '{} :a a)))) "inline get 1") # Regression #24 # f28477649 (def t (put @{} :hi 1)) (assert (deep= t @{:hi 1}) "regression #24") (end-suite) janet-1.41.2/test/suite-compile.janet000066400000000000000000000123551514534607600175020ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Regression Test # 0378ba78 (assert (= 1 (((compile '(fn [] 1) @{})))) "regression test") # Fix a compiler bug in the do special form # 3e1e2585 (defn myfun [x] (var a 10) (set a (do (def _y x) (if x 8 9)))) (assert (= (myfun true) 8) "check do form regression") (assert (= (myfun false) 9) "check do form regression") # Check x:digits: works as symbol and not a hex number # 5baf70f4 (def x1 100) (assert (= x1 100) "x1 as symbol") (def X1 100) (assert (= X1 100) "X1 as symbol") # Edge case should cause old compilers to fail due to # if statement optimization # 17283241 (setdyn *lint-warn* :relaxed) (var var-a 1) (var var-b (if false 2 (string "hello"))) (setdyn *lint-warn* nil) (assert (= var-b "hello") "regression 1") # d28925fda (assert (= (string '()) (string [])) "empty bracket tuple literal") # Bracket tuple issue # 340a6c4 (let [do 3] (assert (= [3 1 2 3] [do 1 2 3]) "bracket tuples are never special forms")) (assert (= ~(,defn 1 2 3) [defn 1 2 3]) "bracket tuples are never macros") (assert (= ~(,+ 1 2 3) [+ 1 2 3]) "bracket tuples are never function calls") # Crash issue #1174 - bad debug info # e97299f (defn crash [] (debug/stack (fiber/current))) (do (math/random) (defn foo [_] (crash) 1) (foo 0) 10) # Issue #1699 - fuzz case with bad def (def result (compile '(defn sum3 "Solve the 3SUM problem in O(n^2) time." [s] (def)tab @{}))) (assert (get result :error) "bad sum3 fuzz issue valgrind") # Issue #1700 (def result (compile '(defn fuzz-case-1 [start end &] (if end (if e start (lazy-range (+ 1 start) end))) 1))) (assert (get result :error) "fuzz case issue #1700") # Issue #1702 - fuzz case with upvalues (def result (compile '(each item [1 2 3] # Generate a lot of upvalues (more than 224) (def ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;out-buf @"") (with-dyns [:out out-buf] 1)))) (assert result "bad upvalues fuzz case") # Named argument linting # Enhancement for #1654 (defn fnamed [&named x y z] [x y z]) (defn fkeys [&keys ks] ks) (defn fnamed2 [_a _b _c &named x y z] [x y z]) (defn fkeys2 [_a _b _c &keys ks] ks) (defn fnamed3 [{:x x} &named a b c] [x a b c]) (defn fnamed4 [_y &opt _z &named a b c] [a b c]) (defn fnamed5 [&opt _z &named a b c] [a b c]) (defn g [x &opt y &named z] [x y z]) (defn check-good-compile [code msg] (def lints @[]) (def result (compile code (curenv) "suite-compile.janet" lints)) (assert (and (function? result) (empty? lints)) msg)) (defn check-lint-compile [code msg] (def lints @[]) (def result (compile code (curenv) "suite-compile.janet" lints)) (assert (and (function? result) (next lints)) msg)) (check-good-compile '(fnamed) "named no args") (check-good-compile '(fnamed :x 1 :y 2 :z 3) "named full args") (check-lint-compile '(fnamed :x) "named odd args") (check-lint-compile '(fnamed :w 0) "named wrong key args") (check-good-compile '(fkeys :a 1) "keys even args") (check-lint-compile '(fkeys :a 1 :b) "keys odd args") (check-good-compile '(fnamed2 nil nil nil) "named 2 no args") (check-good-compile '(fnamed2 nil nil nil :x 1 :y 2 :z 3) "named 2 full args") (check-lint-compile '(fnamed2 nil nil nil :x) "named 2 odd args") (check-lint-compile '(fnamed2 nil nil nil :w 0) "named 2 wrong key args") (check-good-compile '(fkeys2 nil nil nil :a 1) "keys 2 even args") (check-lint-compile '(fkeys2 nil nil nil :a 1 :b) "keys 2 odd args") (check-good-compile '(fnamed3 {:x 1} :a 1 :b 2 :c 3) "named 3 good") (check-lint-compile '(fnamed3 {:x 1} :a 1 :b 2 :d 3) "named 3 lint") (check-good-compile '(fnamed4 10 20 :a 1 :b 2 :c 3) "named 4 good") (check-lint-compile '(fnamed4 10 20 :a 1 :b 2 :d 3) "named 4 lint") (check-good-compile '(fnamed5 10 :a 1 :b 2 :c 3) "named 5 good") (check-lint-compile '(fnamed5 10 :a 1 :b 2 :d 3) "named 5 lint") (check-good-compile '(g 1) "g good 1") (check-good-compile '(g 1 2) "g good 2") (check-good-compile '(g 1 2 :z 10) "g good 3") (check-lint-compile '(g 1 2 :z) "g lint 1") (check-lint-compile '(g 1 2 :z 4 5) "g lint 2") (end-suite) janet-1.41.2/test/suite-corelib.janet000066400000000000000000000205531514534607600174700ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # ac50f62 (assert (= 10 (+ 1 2 3 4)) "addition") (assert (= -8 (- 1 2 3 4)) "subtraction") (assert (= 24 (* 1 2 3 4)) "multiplication") # d6967a5 (assert (= 4 (blshift 1 2)) "left shift") (assert (= 1 (brshift 4 2)) "right shift") # unsigned shift (assert (= 32768 (brushift 0x80000000 16)) "right shift unsigned 1") (assert-error "right shift unsigned 2" (= -32768 (brshift 0x80000000 16))) (assert (= -1 (brshift -1 16)) "right shift unsigned 3") # non-immediate forms (assert (= 32768 (brushift 0x80000000 (+ 0 16))) "right shift unsigned non-immediate") (assert-error "right shift non-immediate" (= -32768 (brshift 0x80000000 (+ 0 16)))) (assert (= -1 (brshift -1 (+ 0 16))) "right shift non-immediate 2") (assert (= 32768 (blshift 1 (+ 0 15))) "left shift non-immediate") # 7e46ead (assert (< 1 2 3 4 5 6) "less than integers") (assert (< 1.0 2.0 3.0 4.0 5.0 6.0) "less than reals") (assert (> 6 5 4 3 2 1) "greater than integers") (assert (> 6.0 5.0 4.0 3.0 2.0 1.0) "greater than reals") (assert (<= 1 2 3 3 4 5 6) "less than or equal to integers") (assert (<= 1.0 2.0 3.0 3.0 4.0 5.0 6.0) "less than or equal to reals") (assert (>= 6 5 4 4 3 2 1) "greater than or equal to integers") (assert (>= 6.0 5.0 4.0 4.0 3.0 2.0 1.0) "greater than or equal to reals") (assert (= 7 (% 20 13)) "rem 1") (assert (= -7 (% -20 13)) "rem 2") (assert (= 7 (% 20 -13)) "rem 3") (assert (= -7 (% -20 -13)) "rem 4") (assert (nan? (% 20 0)) "rem 5") (assert (= 7 (mod 20 13)) "mod 1") (assert (= 6 (mod -20 13)) "mod 2") (assert (= -6 (mod 20 -13)) "mod 3") (assert (= -7 (mod -20 -13)) "mod 4") (assert (= 20 (mod 20 0)) "mod 5") (assert (= 1 (div 20 13)) "div 1") (assert (= -2 (div -20 13)) "div 2") (assert (= -2 (div 20 -13)) "div 3") (assert (= 1 (div -20 -13)) "div 4") (assert (= math/inf (div 20 0)) "div 5") (assert (all = (seq [n :range [0 10]] (mod n 5 3)) (seq [n :range [0 10]] (% n 5 3)) [0 1 2 0 1 0 1 2 0 1]) "variadic mod") # linspace range (assert (deep= @[0 1 2 3] (range 4)) "range 1") (assert (deep= @[0 1 2 3] (range 3.01)) "range 2") (assert (deep= @[0 1 2 3] (range 3.999)) "range 3") (assert (deep= @[0.8 1.8 2.8 3.8] (range 0.8 3.999)) "range 4") (assert (deep= @[0.8 1.8 2.8 3.8] (range 0.8 3.999)) "range 5") (assert (< 1.0 nil false true (fiber/new (fn [] 1)) "hi" (quote hello) :hello (array 1 2 3) (tuple 1 2 3) (table "a" "b" "c" "d") (struct 1 2 3 4) (buffer "hi") (fn [x] (+ x x)) print) "type ordering") # b305a7c9b (assert (= (string (buffer "123" "456")) (string @"123456")) "buffer literal") # 277117165 (assert (= (get {} 1) nil) "get nil from empty struct") (assert (= (get @{} 1) nil) "get nil from empty table") (assert (= (get {:boop :bap} :boop) :bap) "get non nil from struct") (assert (= (get @{:boop :bap} :boop) :bap) "get non nil from table") (assert (= (get @"\0" 0) 0) "get non nil from buffer") (assert (= (get @"\0" 1) nil) "get nil from buffer oob") (assert (put @{} :boop :bap) "can add to empty table") (assert (put @{1 3} :boop :bap) "can add to non-empty table") # 7e46ead (assert (= 7 (bor 3 4)) "bit or") (assert (= 0 (band 3 4)) "bit and") # f41dab8 (assert (= 0xFF (bxor 0x0F 0xF0)) "bit xor") (assert (= 0xF0 (bxor 0xFF 0x0F)) "bit xor 2") # Some testing for not= # 08f6c642d (assert (not= 1 1 0) "not= 1") (assert (not= 0 1 1) "not= 2") # Check if abstract test works # d791077e2 (assert (abstract? stdout) "abstract? stdout") (assert (abstract? stdin) "abstract? stdin") (assert (abstract? stderr) "abstract? stderr") (assert (not (abstract? nil)) "not abstract? nil") (assert (not (abstract? 1)) "not abstract? 1") (assert (not (abstract? 3)) "not abstract? 3") (assert (not (abstract? 5)) "not abstract? 5") # Module path expansion # ff3bb6627 (setdyn :current-file "some-dir/some-file") (defn test-expand [path temp] (string (module/expand-path path temp))) (assert (= (test-expand "abc" ":cur:/:all:") "some-dir/abc") "module/expand-path 1") (assert (= (test-expand "./abc" ":cur:/:all:") "some-dir/abc") "module/expand-path 2") (assert (= (test-expand "abc/def.txt" ":cur:/:name:") "some-dir/def.txt") "module/expand-path 3") (assert (= (test-expand "abc/def.txt" ":cur:/:dir:/sub/:name:") "some-dir/abc/sub/def.txt") "module/expand-path 4") # fc46030e7 (assert (= (test-expand "/abc/../def.txt" ":all:") "/def.txt") "module/expand-path 5") (assert (= (test-expand "abc/../def.txt" ":all:") "def.txt") "module/expand-path 6") (assert (= (test-expand "../def.txt" ":all:") "../def.txt") "module/expand-path 7") (assert (= (test-expand "../././././abcd/../def.txt" ":all:") "../def.txt") "module/expand-path 8") # module/expand-path regression # issue #143 - e0fe8476a (with-dyns [:syspath ".janet/.janet"] (assert (= (string (module/expand-path "hello" ":sys:/:all:.janet")) ".janet/.janet/hello.janet") "module/expand-path 1")) # int? (assert (int? 1) "int? 1") (assert (int? -1) "int? -1") (assert (not (int? true)) "int? true") (assert (not (int? 3.14)) "int? 3.14") (assert (not (int? 8589934592)) "int? 8589934592") # memcmp (assert (= (memcmp "123helloabcd" "1234helloabc" 5 3 4) 0) "memcmp 1") (assert (< (memcmp "123hellaabcd" "1234helloabc" 5 3 4) 0) "memcmp 2") (assert (> (memcmp "123helloabcd" "1234hellaabc" 5 3 4) 0) "memcmp 3") (assert-error "invalid offset-a: 1" (memcmp "a" "b" 1 1 0)) (assert-error "invalid offset-b: 1" (memcmp "a" "b" 1 0 1)) # Range # a982f351d (assert (deep= (range 10) @[0 1 2 3 4 5 6 7 8 9]) "(range 10)") (assert (deep= (range 5 10) @[5 6 7 8 9]) "(range 5 10)") (assert (deep= (range 0 16 4) @[0 4 8 12]) "(range 0 16 4)") (assert (deep= (range 0 17 4) @[0 4 8 12 16]) "(range 0 17 4)") (assert (deep= (range 16 0 -4) @[16 12 8 4]) "(range 16 0 -4)") (assert (deep= (range 17 0 -4) @[17 13 9 5 1]) "(range 17 0 -4)") (assert-error "large range" (range 0xFFFFFFFFFF)) (assert (= (length (range 10)) 10) "(range 10)") (assert (= (length (range -10)) 0) "(range -10)") (assert (= (length (range 1 10)) 9) "(range 1 10)") # iterating over generator (assert-no-error "iterate over coro 1" (values (generate [x :range [0 10]] x))) (assert-no-error "iterate over coro 2" (keys (generate [x :range [0 10]] x))) (assert-no-error "iterate over coro 3" (pairs (generate [x :range [0 10]] x))) # thaw (def ds1 [1 2 3 {:a 2} {:b 3} 4 5 6]) (def ds2 [1 2 3 {:a 2 {:c :d} {:e :f}} {:b 3} 4 5 6]) (assert (deep= (thaw ds1) (thaw-keep-keys ds1)) "thaw vs. thaw-keep-keys 1") (assert (deep-not= (thaw ds2) (thaw-keep-keys ds2)) "thaw vs. thaw-keep-keys 2") # match (setdyn *lint-warn* :none) (assert (= :yes (match [1 2 3] [x y z w] :no1 [x y $] :no2 [x y z] :yes)) "match dollar suffix 1") (assert (= :yes (match [1 2 3] [x y z w] :no1 [x y z $] :yes [x y z] :no2)) "match dollar suffix 2") (setdyn *lint-warn* nil) # Issue #1687 (assert-no-error "def destructure splice works 1" (do (def [a] [;[1]]) a)) (assert-no-error "def destructure splice works 2" (do (def (n) [(splice [])]) n)) (assert-no-error "var destructure splice works" (do (var [a] [;[1]]) a)) # Issue #1709 (assert (= (macex1 '|(set (my-table [2 1]) 'foo)) '(fn :short-fn [] (set (my-table [2 1]) (quote foo)))) "Macro expand inside set preserves tuple type correctly") (end-suite) janet-1.41.2/test/suite-debug.janet000066400000000000000000000025321514534607600171340ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Simple function break # a8afc5b81 (debug/fbreak map 1) (def f (fiber/new (fn [] (map inc [1 2 3])) :a)) (resume f) (assert (= :debug (fiber/status f)) "debug/fbreak") (debug/unfbreak map 1) (map inc [1 2 3]) (end-suite) janet-1.41.2/test/suite-ev.janet000066400000000000000000000425061514534607600164650ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose & contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) (setdyn *lint-warn* :none) (def test-port (os/getenv "JANET_TEST_PORT" "8761")) (def test-host (os/getenv "JANET_TEST_HOST" "127.0.0.1")) # Subprocess # 5e1a8c86f (def janet (dyn *executable*)) # Subprocess should inherit the "RUN" parameter for fancy testing (def run (filter next (string/split " " (os/getenv "SUBRUN" "")))) (repeat 10 (let [p (os/spawn [;run janet "-e" `(print "hello")`] :p {:out :pipe})] (os/proc-wait p) (def x (:read (p :out) :all)) (assert (deep= "hello" (string/trim x)) "capture stdout from os/spawn pre close.")) (let [p (os/spawn [;run janet "-e" `(print "hello")`] :p {:out :pipe})] (def x (:read (p :out) 1024)) (os/proc-wait p) (assert (deep= "hello" (string/trim x)) "capture stdout from os/spawn post close.")) (let [p (os/spawn [;run janet "-e" `(file/read stdin :line)`] :px {:in :pipe})] (:write (p :in) "hello!\n") (assert-no-error "pipe stdin to process" (os/proc-wait p)))) (let [p (os/spawn [;run janet "-e" `(print (file/read stdin :line))`] :px {:in :pipe :out :pipe})] (:write (p :in) "hello!\n") (def x (:read (p :out) 1024)) (assert-no-error "pipe stdin to process 2" (os/proc-wait p)) (assert (= "hello!" (string/trim x)) "round trip pipeline in process")) (let [p (os/spawn [;run janet "-e" `(do (ev/sleep 30) (os/exit 24)`] :p)] (os/proc-kill p) (def retval (os/proc-wait p)) (assert (not= retval 24) "Process was *not* terminated by parent")) (let [p (os/spawn [;run janet "-e" `(do (ev/sleep 30) (os/exit 24)`] :p)] (os/proc-kill p false :term) (def retval (os/proc-wait p)) (assert (not= retval 24) "Process was *not* terminated by parent")) # Parallel subprocesses # 5e1a8c86f (defn calc-1 "Run subprocess, read from stdout, then wait on subprocess." [code] (let [p (os/spawn [;run janet "-e" (string `(printf "%j" ` code `)`)] :px {:out :pipe})] (os/proc-wait p) (def output (:read (p :out) :all)) (parse output))) (assert (deep= (ev/gather (calc-1 "(+ 1 2 3 4)") (calc-1 "(+ 5 6 7 8)") (calc-1 "(+ 9 10 11 12)")) @[10 26 42]) "parallel subprocesses 1") (defn calc-2 `` Run subprocess, wait on subprocess, then read from stdout. Read only up to 10 bytes instead of :all `` [code] (let [p (os/spawn [;run janet "-e" (string `(printf "%j" ` code `)`)] :px {:out :pipe})] (def output (:read (p :out) 10)) (os/proc-wait p) (parse output))) (assert (deep= (ev/gather (calc-2 "(+ 1 2 3 4)") (calc-2 "(+ 5 6 7 8)") (calc-2 "(+ 9 10 11 12)")) @[10 26 42]) "parallel subprocesses 2") # (print "file piping") # File piping # a1cc5ca04 (assert-no-error "file writing 1" (with [f (file/temp)] (os/execute [;run janet "-e" `(repeat 20 (print :hello))`] :p {:out f}))) (assert-no-error "file writing 2" (with [f (file/open "unique.txt" :w)] (os/execute [;run janet "-e" `(repeat 20 (print :hello))`] :p {:out f}) (file/flush f))) # Issue #593 # a1cc5ca04 (assert-no-error "file writing 3" (def outfile (file/open "unique.txt" :w)) (os/execute [;run janet "-e" "(pp (seq [i :range (1 10)] i))"] :p {:out outfile}) (file/flush outfile) (file/close outfile) (os/rm "unique.txt")) # each-line iterator # 70f13f1 (assert-no-error "file/lines iterator" (def outstream (os/open "unique.txt" :wct)) (def buf1 "123\n456\n") (defer (:close outstream) (:write outstream buf1)) (var buf2 "") (with [f (file/open "unique.txt" :r)] (each line (file/lines f) (set buf2 (string buf2 line)))) (assert (= buf1 buf2) "file/lines iterator") (os/rm "unique.txt")) # Ensure that the stream created by os/open works # e8a86013d (assert-no-error "File writing 4.1" (def outstream (os/open "unique.txt" :wct)) (defer (:close outstream) (:write outstream "123\n") (:write outstream "456\n")) # Cast to string to enable comparison (assert (= "123\n456\n" (string (slurp "unique.txt"))) "File writing 4.2") (os/rm "unique.txt")) # Test that the stream created by os/open can be read from # 8d8a6534e (comment (assert-no-error "File reading 1.1" (def outstream (os/open "unique.txt" :wct)) (defer (:close outstream) (:write outstream "123\n") (:write outstream "456\n")) (def outstream (os/open "unique.txt" :r)) (defer (:close outstream) (assert (= "123\n456\n" (string (:read outstream :all))) "File reading 1.2")) (os/rm "unique.txt"))) # ev/gather # 4f2d1cdc0 (assert (deep= @[1 2 3] (ev/gather 1 2 3)) "ev/gather 1") (assert (deep= @[] (ev/gather)) "ev/gather 2") (assert-error "ev/gather 3" (ev/gather 1 2 (error 3))) (var cancel-counter 0) (assert-error "ev/gather 4.1" (ev/gather (defer (++ cancel-counter) (ev/take (ev/chan))) (defer (++ cancel-counter) (ev/take (ev/chan))) (error :oops))) (assert (= cancel-counter 2) "ev/gather 4.2") # Net testing # 2904c19ed (repeat 10 (defn handler "Simple handler for connections." [stream] (defer (:close stream) (def id (gensym)) (def b @"") (net/read stream 1024 b) (net/write stream b) (buffer/clear b))) (def s (net/server test-host test-port handler)) (assert s "made server 1") (defn test-echo [msg] (with [conn (assert (net/connect test-host test-port))] (net/write conn msg) (def res (net/read conn 1024)) (assert (= (string res) msg) (string "echo " msg)))) (test-echo "hello") (test-echo "world") (test-echo (string/repeat "abcd" 200)) (:close s) (gccollect)) # Test on both server and client # 504411e (var iterations 0) (defn names-handler [stream] (defer (:close stream) # prevent immediate close (ev/read stream 1) (def [host port] (net/localname stream)) (assert (= host test-host) "localname host server") (assert (= port (scan-number test-port)) "localname port server") (++ iterations) (ev/write stream " "))) # (print "local name / peer name testing") # Test localname and peername # 077bf5eba (repeat 10 (with [s (net/server test-host test-port names-handler)] (repeat 10 (with [conn (assert (net/connect test-host test-port))] (def [host port] (net/peername conn)) (assert (= host test-host) "peername host client ") (assert (= port (scan-number test-port)) "peername port client") (++ iterations) (ev/write conn " ") (ev/read conn 1)))) (gccollect)) (assert (= iterations 200) "localname and peername not enough checks") # Create pipe # 12f09ad2d (var pipe-counter 0) (def chan (ev/chan 10)) (let [[reader writer] (os/pipe)] (ev/spawn (while (ev/read reader 3) (++ pipe-counter)) (assert (= 20 pipe-counter) "ev/pipe 1") (ev/give chan 1)) (for i 0 10 (ev/write writer "xxx---")) (ev/close writer) (ev/take chan)) # cff52ded5 (var result nil) (var fiber nil) (set fiber (ev/spawn (set result (protect (ev/sleep 10))) (assert (= result '(false "boop")) "ev/cancel 1"))) (ev/sleep 0) (ev/cancel fiber "boop") # f0dbc2e (assert (os/execute [;run janet "-e" `(+ 1 2 3)`] :xp) "os/execute self") # Test some channel # e76b8da26 (def c1 (ev/chan)) (def c2 (ev/chan)) (def arr @[]) (ev/spawn (while (def x (ev/take c1)) (array/push arr x)) (ev/chan-close c2)) (for i 0 1000 (ev/give c1 i)) (ev/chan-close c1) (ev/take c2) (assert (= (slice arr) (slice (range 1000))) "ev/chan-close 1") (def c1 (ev/chan)) (def c2 (ev/chan)) (def arr @[]) (ev/spawn (while (def x (ev/take c1)) (array/push arr x)) (ev/sleep 0.1) (ev/chan-close c2)) (for i 0 100 (ev/give c1 i)) (ev/chan-close c1) (ev/select c2) (assert (= (slice arr) (slice (range 100))) "ev/chan-close 2") (def c1 (ev/chan)) (def c2 (ev/chan)) (def arr @[]) (ev/spawn (while (def x (ev/take c1)) (array/push arr x)) (ev/chan-close c2)) (for i 0 100 (ev/give c1 i)) (ev/chan-close c1) (ev/rselect c2) (assert (= (slice arr) (slice (range 100))) "ev/chan-close 3") # threaded channels # 868cdb9 (def ch (ev/thread-chan 2)) (def att (ev/thread-chan 109)) (assert att "`att` was nil after creation") (ev/give ch att) (ev/do-thread (assert (ev/take ch) "channel packing bug for threaded abstracts on threaded channels.")) # marshal channels # 76be8006a (def ch (ev/chan 10)) (ev/give ch "hello") (ev/give ch "world") (def ch2 (-> ch marshal unmarshal)) (def item1 (ev/take ch2)) (def item2 (ev/take ch2)) (assert (= item1 "hello")) (assert (= item2 "world")) # ev/take, suspended, channel closed (def ch (ev/chan)) (ev/go |(ev/chan-close ch)) (assert (= (ev/take ch) nil)) # ev/give, suspended, channel closed (def ch (ev/chan)) (ev/go |(ev/chan-close ch)) (assert (= (ev/give ch 1) nil)) # ev/select, suspended take operation, channel closed (def ch (ev/chan)) (ev/go |(ev/chan-close ch)) (assert (= (ev/select ch) [:close ch])) # ev/select, suspended give operation, channel closed (def ch (ev/chan)) (ev/go |(ev/chan-close ch)) (assert (= (ev/select [ch 1]) [:close ch])) # ev/gather check (defn exec-slurp "Read stdout of subprocess and return it trimmed in a string." [& args] (def env (os/environ)) (put env :out :pipe) (def proc (os/spawn args :epx env)) (def out (get proc :out)) (def buf @"") (ev/gather (:read out :all buf) (:wait proc)) (string/trimr buf)) (assert-no-error "ev/with-deadline 1" (assert (= "hi" (ev/with-deadline 10 (exec-slurp ;run janet "-e" "(print :hi)"))) "exec-slurp 1")) # valgrind-able check for #1337 (def superv (ev/chan 10)) (def f (ev/go |(ev/sleep 1e9) nil superv)) (ev/cancel f (gensym)) (ev/take superv) # Chat server test (def conmap @{}) (defn broadcast [em msg] (eachk par conmap (if (not= par em) (if-let [tar (get conmap par)] (net/write tar (string/format "[%s]:%s" em msg)))))) (defn handler [connection] (net/write connection "Whats your name?\n") (def name (string/trim (string (ev/read connection 100)))) (if (get conmap name) (do (net/write connection "Name already taken!") (:close connection)) (do (put conmap name connection) (net/write connection (string/format "Welcome %s\n" name)) (defer (do (put conmap name nil) (:close connection)) (while (def msg (ev/read connection 100)) (broadcast name (string msg))))))) # (print "chat app testing") # Now launch the chat server (def chat-server (net/listen test-host test-port)) (ev/spawn (forever (def [ok connection] (protect (net/accept chat-server))) (if (and ok connection) (ev/call handler connection) (break)))) # Make sure we can't bind again with no-reuse (assert-error "no-reuse" (net/listen test-host test-port :stream true)) # Read from socket (defn expect-read [stream text] (def result (string (net/read stream 100))) (assert (= result text) (string/format "expected %v, got %v" text result))) # Now do our telnet chat (def bob (assert (net/connect test-host test-port :stream))) (expect-read bob "Whats your name?\n") (net/write bob "bob") (expect-read bob "Welcome bob\n") (def alice (assert (net/connect test-host test-port))) (expect-read alice "Whats your name?\n") (net/write alice "alice") (expect-read alice "Welcome alice\n") # Bob says hello, alice gets the message (net/write bob "hello\n") (expect-read alice "[bob]:hello\n") # Alice says hello, bob gets the message (net/write alice "hi\n") (expect-read bob "[alice]:hi\n") # Ted joins the chat server (def ted (assert (net/connect test-host test-port))) (expect-read ted "Whats your name?\n") (net/write ted "ted") (expect-read ted "Welcome ted\n") # Ted says hi, alice and bob get message (net/write ted "hi\n") (expect-read alice "[ted]:hi\n") (expect-read bob "[ted]:hi\n") # Bob leaves for work. Now it's just ted and alice (:close bob) # Alice messages ted, ted gets message (net/write alice "wuzzup\n") (expect-read ted "[alice]:wuzzup\n") (net/write ted "not much\n") (expect-read alice "[ted]:not much\n") # Alice bounces (:close alice) # Ted can send messages, nobody gets them :( (net/write ted "hello?\n") (:close ted) # Close chat server (:close chat-server) # Issue #1531 (defn sleep-print [x] (ev/sleep 0) (print x)) (protect (with-dyns [*out* sleep-print] (prin :foo))) (defn level-trigger-handling [conn &] (:close conn)) (def s (assert (net/server test-host test-port level-trigger-handling))) (def c (assert (net/connect test-host test-port))) (:close s) # Issue #1531 no. 2 (def c (ev/chan 0)) (ev/spawn (while (def x (ev/take c)))) (defn print-to-chan [x] (ev/give c x)) (assert-error "coerce await inside janet_call to error" (with-dyns [*out* print-to-chan] (pp :foo))) (ev/chan-close c) # soreuseport on unix domain sockets (compwhen (or (= :macos (os/which)) (= :linux (os/which))) (assert-no-error "unix-domain socket reuseaddr" (let [uds-path "./unix-domain-socket"] (defer (os/rm uds-path) (let [s (net/listen :unix uds-path :stream)] (:close s)))))) # (print "accept loop testing") # net/accept-loop level triggering (gccollect) (def maxconn 50) (var connect-count 0) (defn level-trigger-handling [conn &] (with [conn conn] (ev/write conn (ev/read conn 4096)) (++ connect-count))) (def s (assert (net/server test-host test-port level-trigger-handling))) (def cons @[]) (repeat maxconn (array/push cons (assert (net/connect test-host test-port)))) (assert (= maxconn (length cons))) (defn do-connect [i] (with [c (get cons i)] (ev/write c "abc123") (ev/read c 4096))) (for i 0 maxconn (ev/spawn (do-connect i))) (ev/sleep 0.1) (assert (= maxconn connect-count)) (:close s) # (print "running deadline tests...") # Cancel os/proc-wait with ev/deadline (let [p (os/spawn [;run janet "-e" "(os/sleep 4)"] :p)] (var terminated-normally false) (assert-error "deadline expired" (ev/with-deadline 0.01 (os/proc-wait p) (print "uhoh") (set terminated-normally true))) (assert (not terminated-normally) "early termination failure") # Without this kill, janet will wait the full 4 seconds for the subprocess to complete before exiting. (assert-no-error "kill proc after wait failed" (os/proc-kill p))) # Cancel os/proc-wait with ev/deadline 2 (let [p (os/spawn [;run janet "-e" "(os/sleep 0.1)"] :p)] (var terminated-normally false) (assert-error "deadline expired" (ev/with-deadline 0.05 (os/proc-wait p) (print "uhoh") (set terminated-normally true))) (assert (not terminated-normally) "early termination failure 2") (ev/sleep 0.15) (assert (not terminated-normally) "early termination failure 3")) # Deadline with interrupt (defmacro with-deadline2 `` Create a fiber to execute `body`, schedule the event loop to cancel the task (root fiber) associated with `body`'s fiber, and start `body`'s fiber by resuming it. The event loop will try to cancel the root fiber if `body`'s fiber has not completed after at least `sec` seconds. `sec` is a number that can have a fractional part. `` [sec & body] (with-syms [f] ~(let [,f (coro ,;body)] (,ev/deadline ,sec nil ,f true) (,resume ,f)))) (for i 0 10 # (print "deadline 1 iteration " i) (assert (= :done (with-deadline2 10 (ev/sleep 0.01) :done)) "deadline with interrupt exits normally")) (for i 0 10 # (print "deadline 2 iteration " i) (let [f (coro (forever :foo))] (ev/deadline 0.01 nil f true) (assert-error "deadline expired" (resume f)))) # Use :err :stdout (def- subproc-code '(do (eprint "hi") (eflush) (print "there") (flush))) (defn ev/slurp [f &opt buf] (default buf @"") (if (ev/read f 0x10000 buf) (ev/slurp f buf) buf)) (def p (os/spawn [;run janet "-e" (string/format "%j" subproc-code)] :px {:out :pipe :err :out})) (def [exit-code data] (ev/gather (os/proc-wait p) (ev/slurp (p :out)))) (def data (string/replace-all "\r" "" data)) (assert (zero? exit-code) "subprocess ran") (assert (= data "hi\nthere\n") "output is correct") (end-suite) janet-1.41.2/test/suite-ev2.janet000066400000000000000000000054731514534607600165510ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose & contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Issue #1629 (def thread-channel (ev/thread-chan 100)) (def super (ev/thread-chan 10)) (defn worker [] (while true (def item (ev/take thread-channel)) (when (= item :deadline) (ev/deadline 0.1 nil (fiber/current) true)))) (ev/thread worker nil :n super) (ev/give thread-channel :item) (ev/sleep 0.05) (ev/give thread-channel :item) (ev/sleep 0.05) (ev/give thread-channel :deadline) (ev/sleep 0.05) (ev/give thread-channel :item) (ev/sleep 0.05) (ev/give thread-channel :item) (ev/sleep 0.15) (assert (deep= '(:error "deadline expired" nil) (ev/take super)) "deadline expirataion") # Another variant (def thread-channel (ev/thread-chan 100)) (def super (ev/thread-chan 10)) (defn worker [] (while true (def item (ev/take thread-channel)) (when (= item :deadline) (ev/deadline 0.1)))) (ev/thread worker nil :n super) (ev/give thread-channel :deadline) (ev/sleep 0.2) (assert (deep= '(:error "deadline expired" nil) (ev/take super)) "deadline expirataion") # Issue #1705 - ev select (def supervisor (ev/chan 10)) (def ch (ev/chan)) (def ch2 (ev/chan)) (ev/go |(do (ev/select ch ch2) (:close ch) "close ch...") nil supervisor) (ev/go |(do (ev/sleep 0.05) (:close ch2) "close ch2...") nil supervisor) (assert (let [[status] (ev/take supervisor)] (= status :ok)) "status 1 ev/select") (assert (let [[status] (ev/take supervisor)] (= status :ok)) "status 2 ev/select") (ev/sleep 0.1) # can we do better? (assert (= 0 (ev/count supervisor)) "empty supervisor") # Issue #1707 (def f (coro (repeat 10 (yield 1)))) (resume f) (assert-error "cannot schedule non-new fiber" (ev/go f)) (end-suite) janet-1.41.2/test/suite-ffi.janet000066400000000000000000000045621514534607600166170ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose & contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) (var has-ffi (dyn 'ffi/native)) (def has-full-ffi (and has-ffi (when-let [entry (dyn 'ffi/calling-conventions)] (def fficc (entry :value)) (> (length (fficc)) 1)))) # all arches support :none # FFI check # d80356158 (compwhen has-ffi (ffi/context)) (compwhen has-ffi (ffi/defbind memcpy :ptr [dest :ptr src :ptr n :size])) (compwhen has-full-ffi (def buffer1 @"aaaa") (def buffer2 @"bbbb") (memcpy buffer1 buffer2 4) (assert (= (string buffer1) "bbbb") "ffi 1 - memcpy")) # cfaae47ce (compwhen has-ffi (assert (= 8 (ffi/size [:int :char])) "size unpacked struct 1") (assert (= 5 (ffi/size [:pack :int :char])) "size packed struct 1") (assert (= 5 (ffi/size [:int :pack-all :char])) "size packed struct 2") (assert (= 4 (ffi/align [:int :char])) "align 1") (assert (= 1 (ffi/align [:pack :int :char])) "align 2") (assert (= 1 (ffi/align [:int :char :pack-all])) "align 3") (assert (= 26 (ffi/size [:char :pack :int @[:char 21]])) "array struct size")) (compwhen has-ffi (assert-error "bad struct issue #1512" (ffi/struct :void))) (compwhen has-ffi (def buf @"") (ffi/write :u8 10 buf) (assert (= 1 (length buf))) (ffi/write :u8 10 buf) (assert (= 2 (length buf)))) (end-suite) janet-1.41.2/test/suite-filewatch.janet000066400000000000000000000141511514534607600200140ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose & contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) (assert true) (def chan (ev/chan 1000)) (var is-win (or (= :mingw (os/which)) (= :windows (os/which)))) (var is-linux (= :linux (os/which))) # If not supported, exit early (def [supported msg] (protect (filewatch/new chan))) (when (and (not supported) (string/find "filewatch not supported" msg)) (end-suite) (quit)) # Test GC (assert-no-error "filewatch/new" (filewatch/new chan)) (gccollect) (defn- expect [key value & more-kvs] (ev/with-deadline 1 (def event (ev/take chan)) (when is-verbose (pp event)) (assert event "check event") (assert (= value (get event key)) (string/format "got %p, expected %p" (get event key) value)) (when (next more-kvs) (each [k v] (partition 2 more-kvs) (assert (= v (get event k)) (string/format "got %p, expected %p" (get event k) v)))))) (defn- expect-empty [] (assert (zero? (ev/count chan)) "channel check empty") (ev/sleep 0) # turn the event loop (assert (zero? (ev/count chan)) "channel check empty") # Drain if not empty, help with failures after this (while (pos? (ev/count chan)) (printf "extra: %p" (ev/take chan)))) (defn- expect-maybe "On wine + mingw, we get an extra event. This is a wine peculiarity." [key value] (ev/with-deadline 1 (ev/sleep 0) (when (pos? (ev/count chan)) (def event (ev/take chan)) (when is-verbose (pp event)) (assert event "check event") (assert (= value (get event key)) (string/format "got %p, expected %p" (get event key) value))))) (defn spit-file [dir name] (def path (string dir "/" name)) (spit path "test text")) # Different operating systems report events differently. While it would be nice to # normalize this, each system has very large limitations in what can be reported when # compared with other systems. As such, the maximum subset of common functionality here # is quite small. Instead, test the capabilities of each system. # Create a file watcher on two test directories (def fw (filewatch/new chan)) (def td1 (randdir)) (def td2 (randdir)) (def td3 (randdir)) (rmrf td1) (rmrf td2) (os/mkdir td1) (os/mkdir td2) (os/mkdir td3) (spit-file td3 "file3.txt") (when is-win (filewatch/add fw td1 :last-write :last-access :file-name :dir-name :size :attributes :recursive) (filewatch/add fw td2 :last-write :last-access :file-name :dir-name :size :attributes)) (when is-linux (filewatch/add fw (string td3 "/file3.txt") :close-write :create :delete) (filewatch/add fw td1 :close-write :create :delete) (filewatch/add fw td2 :close-write :create :delete :ignored)) (assert-no-error "filewatch/listen no error" (filewatch/listen fw)) # # Windows file writing # (when is-win (spit-file td1 "file1.txt") (expect :type :added :file-name "file1.txt" :dir-name td1) (expect :type :modified) (expect-maybe :type :modified) # for mingw + wine (gccollect) (spit-file td1 "file1.txt") (expect :type :modified) (expect :type :modified) (expect-empty) (gccollect) # Check td2 (spit-file td2 "file2.txt") (expect :type :added) (expect :type :modified) (expect-maybe :type :modified) # Remove a file, then wait for remove event (rmrf (string td1 "/file1.txt")) (expect :type :removed) (expect-empty) # Unlisten to some events (filewatch/remove fw td2) # Check that we don't get anymore events from test directory 2 (spit-file td2 "file2.txt") (expect-empty) # Repeat and things should still work with test directory 1 (spit-file td1 "file1.txt") (expect :type :added) (expect :type :modified) (expect-maybe :type :modified) (gccollect) (spit-file td1 "file1.txt") (expect :type :modified) (expect :type :modified) (expect-maybe :type :modified) (gccollect)) # # Linux file writing # (when is-linux (spit-file td1 "file1.txt") (expect :type :create :file-name "file1.txt" :dir-name td1) (expect :type :close-write) (expect-empty) (gccollect) (spit-file td1 "file1.txt") (expect :type :close-write) (expect-empty) (gccollect) # Check file3.txt (spit-file td3 "file3.txt") (expect :type :close-write :file-name "file3.txt" :dir-name td3) (expect-empty) # Check td2 (spit-file td2 "file2.txt") (expect :type :create) (expect :type :close-write) (expect-empty) # Remove a file, then wait for remove event (rmrf (string td1 "/file1.txt")) (expect :type :delete) (expect-empty) # Unlisten to some events (filewatch/remove fw td2) (expect :type :ignored) (expect-empty) # Check that we don't get anymore events from test directory 2 (spit-file td2 "file2.txt") (expect-empty) # Repeat and things should still work with test directory 1 (spit-file td1 "file1.txt") (expect :type :create) (expect :type :close-write) (expect-empty) (gccollect) (spit-file td1 "file1.txt") (expect :type :close-write) (expect-empty) (gccollect)) (assert-no-error "filewatch/unlisten no error" (filewatch/unlisten fw)) (assert-no-error "cleanup 1" (rmrf td1)) (assert-no-error "cleanup 2" (rmrf td2)) (assert-no-error "cleanup 3" (rmrf td3)) (end-suite) janet-1.41.2/test/suite-inttypes.janet000066400000000000000000000243261514534607600177320ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose & contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Disable linting warnings (setdyn *lint-warn* :none) # some tests for bigint # 319575c (def i64 int/s64) (def u64 int/u64) (assert-no-error "create some uint64 bigints" (do # from number (def a (u64 10)) # max double we can convert to int (2^53) (def b (u64 0x1fffffffffffff)) (def b (u64 (math/pow 2 53))) # from string (def c (u64 "0xffff_ffff_ffff_ffff")) (def c (u64 "32rvv_vv_vv_vv")) (def d (u64 "123456789")))) # Conversion back to an int32 # 88db9751d (assert (= (int/to-number (u64 0xFaFa)) 0xFaFa)) (assert (= (int/to-number (i64 0xFaFa)) 0xFaFa)) (assert (= (int/to-number (u64 9007199254740991)) 9007199254740991)) (assert (= (int/to-number (i64 9007199254740991)) 9007199254740991)) (assert (= (int/to-number (i64 -9007199254740991)) -9007199254740991)) # New parser (assert (= (u64 "123") 123:u) "u64 parsing") (assert (= (u64 "0") 0:u) "u64 parsing") (assert (= (u64 "0xFFFF_FFFF_FFFF_FFFF") 0xFFFF_FFFF_FFFF_FFFF:u) "u64 parsing") (assert (= (i64 "123") 123:s) "s64 parsing") (assert (= (i64 "-123") -123:s) "s64 parsing") (assert (= (i64 "0") 0:s) "s64 parsing") (assert-error "u64 out of bounds for safe integer" (int/to-number (u64 "9007199254740993")) (assert-error "s64 out of bounds for safe integer" (int/to-number (i64 "-9007199254740993")))) (assert-error "int/to-number fails on non-abstract types" (int/to-number 1)) (assert-no-error "create some int64 bigints" (do # from number (def a (i64 -10)) # max double we can convert to int (2^53) (def b (i64 0x1fffffffffffff)) (def b (i64 (math/pow 2 53))) # from string (def c (i64 "0x7fff_ffff_ffff_ffff")) (def d (i64 "123456789")))) (assert-error "bad initializers" (do # double to big to be converted to uint64 without truncation (2^53 + 1) (def b (u64 (+ 0xffff_ffff_ffff_ff 1))) (def b (u64 (+ (math/pow 2 53) 1))) # out of range 65 bits (def c (u64 "0x1ffffffffffffffff")) # just to big (def d (u64 "123456789123456789123456789")))) (assert (= (:/ (u64 "0xffff_ffff_ffff_ffff") 8 2) (u64 "0xfffffffffffffff")) "bigint operations 1") (assert (let [a (u64 0xff)] (= (:+ a a a a) (:* a 2 2))) "bigint operations 2") # 5ae520a2c (assert (= (string (i64 -123)) "-123") "i64 prints reasonably") (assert (= (string (u64 123)) "123") "u64 prints reasonably") # 1db6d0e0b (assert-error "trap INT64_MIN / -1" (:/ (int/s64 "-0x8000_0000_0000_0000") -1)) # int/s64 and int/u64 serialization # 6aea7c7f7 (assert (deep= (int/to-bytes (u64 0)) @"\x00\x00\x00\x00\x00\x00\x00\x00")) (assert (deep= (int/to-bytes (i64 1) :le) @"\x01\x00\x00\x00\x00\x00\x00\x00")) (assert (deep= (int/to-bytes (i64 1) :be) @"\x00\x00\x00\x00\x00\x00\x00\x01")) (assert (deep= (int/to-bytes (i64 -1)) @"\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF")) (assert (deep= (int/to-bytes (i64 -5) :be) @"\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFB")) (assert (deep= (int/to-bytes (u64 1) :le) @"\x01\x00\x00\x00\x00\x00\x00\x00")) (assert (deep= (int/to-bytes (u64 1) :be) @"\x00\x00\x00\x00\x00\x00\x00\x01")) (assert (deep= (int/to-bytes (u64 300) :be) @"\x00\x00\x00\x00\x00\x00\x01\x2C")) # int/s64 int/u64 to existing buffer # bbb3e16fd (let [buf1 @"" buf2 @"abcd"] (assert (deep= (int/to-bytes (i64 1) :le buf1) @"\x01\x00\x00\x00\x00\x00\x00\x00")) (assert (deep= buf1 @"\x01\x00\x00\x00\x00\x00\x00\x00")) (assert (deep= (int/to-bytes (u64 300) :be buf2) @"abcd\x00\x00\x00\x00\x00\x00\x01\x2C"))) # int/s64 and int/u64 parameter type checking # 6aea7c7f7 (assert-error "bad value passed to int/to-bytes" (int/to-bytes 1)) # 6aea7c7f7 (assert-error "invalid endianness passed to int/to-bytes" (int/to-bytes (u64 0) :little)) # bbb3e16fd (assert-error "invalid buffer passed to int/to-bytes" (int/to-bytes (u64 0) :little :buffer)) # Right hand operators # 4fe005e3c (assert (= (int/s64 (sum (range 10))) (sum (map int/s64 (range 10)))) "right hand operators 1") (assert (= (int/s64 (product (range 1 10))) (product (map int/s64 (range 1 10)))) "right hand operators 2") (assert (= (int/s64 15) (bor 10 (int/s64 5)) (bor (int/s64 10) 5)) "right hand operators 3") # Integer type checks # 11067d7a5 (assert (compare= 0 (- (int/u64 "1000") 1000)) "subtract from int/u64") (assert (odd? (int/u64 "1001")) "odd? 1") (assert (not (odd? (int/u64 "1000"))) "odd? 2") (assert (odd? (int/s64 "1001")) "odd? 3") (assert (not (odd? (int/s64 "1000"))) "odd? 4") (assert (odd? (int/s64 "-1001")) "odd? 5") (assert (not (odd? (int/s64 "-1000"))) "odd? 6") (assert (even? (int/u64 "1000")) "even? 1") (assert (not (even? (int/u64 "1001"))) "even? 2") (assert (even? (int/s64 "1000")) "even? 3") (assert (not (even? (int/s64 "1001"))) "even? 4") (assert (even? (int/s64 "-1000")) "even? 5") (assert (not (even? (int/s64 "-1001"))) "even? 6") # integer type operations (defn opcheck [int x y] (each op [mod % div] (assert (compare= (op x y) (op (int x) y)) (string int " (" op " " x " " y ") expected " (op x y) ", got " (op (int x) y))) (assert (compare= (op x y) (op x (int y))) (string int " (" op " " x " " y ") expected " (op x y) ", got " (op x (int y)))) (assert (compare= (op x y) (op (int x) (int y))) (string int " (" op " " x " " y ") expected " (op x y) ", got " (op (int x) (int y)))))) (loop [x :in [-5 -3 0 3 5] y :in [-4 -3 3 4]] (opcheck int/s64 x y) (if (and (>= x 0) (>= y 0)) (opcheck int/u64 x y))) (each int [int/s64 int/u64] (each op [% / div] (assert-error "division by zero" (op (int 7) 0)) (assert-error "division by zero" (op 7 (int 0))) (assert-error "division by zero" (op (int 7) (int 0))))) (each int [int/s64 int/u64] (loop [x :in [-5 -3 0 3 5] :when (or (pos? x) (= int int/s64))] # skip check when comparing negative values with unsigned integers. (assert (= (int x) (mod (int x) 0)) (string int " mod 0")) (assert (= (int x) (mod x (int 0))) (string int " mod 0")) (assert (= (int x) (mod (int x) (int 0))) (string int " mod 0")))) (loop [x :in [-5 -3 0 3 5]] (assert (compare= (bnot x) (bnot (int/s64 x))) "int/s64 bnot")) (loop [x :range [0 10]] (assert (= (int/u64 "0xFFFF_FFFF_FFFF_FFFF") (bxor (int/u64 x) (bnot (int/u64 x)))) "int/u64 bnot")) # Check for issue #1130 # 7e65c2bda (var d (int/s64 7)) (mod 0 d) (var d (int/s64 7)) (def result (seq [n :in (range -21 0)] (mod n d))) (assert (deep= result (map int/s64 @[0 1 2 3 4 5 6 0 1 2 3 4 5 6 0 1 2 3 4 5 6])) "issue #1130") # issue #272 - 81d301a42 (let [MAX_INT_64_STRING "9223372036854775807" MAX_UINT_64_STRING "18446744073709551615" MAX_INT_IN_DBL_STRING "9007199254740991" NAN (math/log -1) INF (/ 1 0) MINUS_INF (/ -1 0) compare-poly-tests [[(int/s64 3) (int/u64 3) 0] [(int/s64 -3) (int/u64 3) -1] [(int/s64 3) (int/u64 2) 1] [(int/s64 3) 3 0] [(int/s64 3) 4 -1] [(int/s64 3) -9 1] [(int/u64 3) 3 0] [(int/u64 3) 4 -1] [(int/u64 3) -9 1] [3 (int/s64 3) 0] [3 (int/s64 4) -1] [3 (int/s64 -5) 1] [3 (int/u64 3) 0] [3 (int/u64 4) -1] [3 (int/u64 2) 1] [(int/s64 MAX_INT_64_STRING) (int/u64 MAX_UINT_64_STRING) -1] [(int/s64 MAX_INT_IN_DBL_STRING) (scan-number MAX_INT_IN_DBL_STRING) 0] [(int/u64 MAX_INT_IN_DBL_STRING) (scan-number MAX_INT_IN_DBL_STRING) 0] [(+ 1 (int/u64 MAX_INT_IN_DBL_STRING)) (scan-number MAX_INT_IN_DBL_STRING) 1] [(int/s64 0) INF -1] [(int/u64 0) INF -1] [MINUS_INF (int/u64 0) -1] [MINUS_INF (int/s64 0) -1] [(int/s64 1) NAN 0] [NAN (int/u64 1) 0]]] (each [x y c] compare-poly-tests (assert (= c (compare x y)) (string/format "compare polymorphic %q %q %d" x y c)))) # marshal (def m1 (u64 3141592654)) (def m2 (unmarshal (marshal m1))) (assert (= m1 m2) "marshal/unmarshal") # compare u64/u64 (assert (= (compare (u64 1) (u64 2)) -1) "compare 1") (assert (= (compare (u64 1) (u64 1)) 0) "compare 2") (assert (= (compare (u64 2) (u64 1)) +1) "compare 3") # compare i64/i64 (assert (= (compare (i64 -1) (i64 +1)) -1) "compare 4") (assert (= (compare (i64 +1) (i64 +1)) 0) "compare 5") (assert (= (compare (i64 +1) (i64 -1)) +1) "compare 6") # compare u64/i64 (assert (= (compare (u64 1) (i64 2)) -1) "compare 7") (assert (= (compare (u64 1) (i64 -1)) +1) "compare 8") (assert (= (compare (u64 0) (i64 -1)) +1) "compare 9") # compare i64/u64 (assert (= (compare (i64 1) (u64 2)) -1) "compare 10") (assert (= (compare (i64 -1) (u64 1)) -1) "compare 11") (assert (= (compare (i64 -1) (u64 0)) -1) "compare 12") # off by 1 error in inttypes # a3e812b86 (assert (= (int/s64 "-0x8000_0000_0000_0000") (+ (int/s64 "0x7FFF_FFFF_FFFF_FFFF") 1)) "int types wrap around") (assert (= (int/s64 "0x7FFF_FFFF_FFFF_FFFF") (- (int/s64 "-0x8000_0000_0000_0000") 1)) "int types wrap around") # Issue #1217 (assert (= (- (int/u64 "0xFFFFFFFF") 1) (int/u64 "0xFFFFFFFE")) "u64 subtract") (end-suite) janet-1.41.2/test/suite-io.janet000066400000000000000000000050471514534607600164610ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose & contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Printing to buffers # d47804d22 (def out-buf @"") (def err-buf @"") (with-dyns [:out out-buf :err err-buf] (print "Hello") (prin "hi") (eprint "Sup") (eprin "not much.")) (assert (= (string out-buf) "Hello\nhi") "print and prin to buffer 1") (assert (= (string err-buf) "Sup\nnot much.") "eprint and eprin to buffer 1") # Printing to functions # 4e263b8c3 (def out-buf @"") (defn prepend [x] (with-dyns [:out out-buf] (prin "> " x))) (with-dyns [:out prepend] (print "Hello world")) (assert (= (string out-buf) "> Hello world\n") "print to buffer via function") # c2f844157, 3c523d66e (with [f (file/temp)] (assert (= 0 (file/tell f)) "start of file") (file/write f "foo\n") (assert (= 4 (file/tell f)) "after written string") (file/flush f) (file/seek f :set 0) (assert (= 0 (file/tell f)) "start of file again") (assert (= (string (file/read f :all)) "foo\n") "temp files work")) # issue #1055 - 2c927ea76 (let [b @""] (defn dummy [a b c] (+ a b c)) (trace dummy) (defn errout [arg] (buffer/push b arg)) (assert (= 6 (with-dyns [*err* errout] (dummy 1 2 3))) "trace to custom err function") (assert (deep= @"trace (dummy 1 2 3)\n" b) "trace buffer correct")) # xprintf (def b @"") (defn to-b [a] (buffer/push b a)) (xprintf to-b "123") (assert (deep= b @"123\n") "xprintf to buffer") (assert-error "cannot print to 3" (xprintf 3 "123")) (end-suite) janet-1.41.2/test/suite-marsh.janet000066400000000000000000000176571514534607600171760ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Marshal # 98f2c6f (def um-lookup (env-lookup (fiber/getenv (fiber/current)))) (def m-lookup (invert um-lookup)) # 0cf10946b (defn testmarsh [x msg] (def marshx (marshal x m-lookup)) (def out (marshal (unmarshal marshx um-lookup) m-lookup)) (assert (= (string marshx) (string out)) msg)) (testmarsh nil "marshal nil") (testmarsh false "marshal false") (testmarsh true "marshal true") (testmarsh 1 "marshal small integers") (testmarsh -1 "marshal integers (-1)") (testmarsh 199 "marshal small integers (199)") (testmarsh 5000 "marshal medium integers (5000)") (testmarsh -5000 "marshal small integers (-5000)") (testmarsh 10000 "marshal large integers (10000)") (testmarsh -10000 "marshal large integers (-10000)") (testmarsh 1.0 "marshal double") (testmarsh "doctordolittle" "marshal string") (testmarsh :chickenshwarma "marshal symbol") (testmarsh @"oldmcdonald" "marshal buffer") (testmarsh @[1 2 3 4 5] "marshal array") (testmarsh [tuple 1 2 3 4 5] "marshal tuple") (testmarsh @{1 2 3 4} "marshal table") (testmarsh {1 2 3 4} "marshal struct") (testmarsh (fn [x] x) "marshal function 0") (testmarsh (fn name [x] x) "marshal function 1") (testmarsh (fn [x] (+ 10 x 2)) "marshal function 2") (testmarsh (fn thing [x] (+ 11 x x 30)) "marshal function 3") (testmarsh map "marshal function 4") (testmarsh reduce "marshal function 5") (testmarsh (fiber/new (fn [] (yield 1) 2)) "marshal simple fiber 1") (testmarsh (fiber/new (fn [&] (yield 1) 2)) "marshal simple fiber 2") # issue #53 - 1147482e6 (def strct {:a @[nil]}) (put (strct :a) 0 strct) (testmarsh strct "cyclic struct") # More marshalling code # issue #53 - 1147482e6 (defn check-image "Run a marshaling test using the make-image and load-image functions." [x msg] (def im (make-image x)) # (printf "\nimage-hash: %d" (-> im string hash)) (assert-no-error msg (load-image im))) (check-image (fn [] (fn [] 1)) "marshal nested functions") (check-image (fiber/new (fn [] (fn [] 1))) "marshal nested functions in fiber") (check-image (fiber/new (fn [] (fiber/new (fn [] 1)))) "marshal nested fibers") # issue #53 - f4908ebc4 (setdyn *lint-warn* :none) (def issue-53-x (fiber/new (fn [] (var y (fiber/new (fn [] (print "1") (yield) (print "2"))))))) (setdyn *lint-warn* nil) (check-image issue-53-x "issue 53 regression") # Marshal closure over non resumable fiber # issue #317 - 7c4ffe9b9 (do (defn f1 [a] (defn f1 [] (++ (a 0))) (defn f2 [] (++ (a 0))) (error [f1 f2])) (def [_ tup] (protect (f1 @[0]))) (def [f1 f2] (unmarshal (marshal tup make-image-dict) load-image-dict)) (assert (= 1 (f1)) "marshal-non-resumable-closure 1") (assert (= 2 (f2)) "marshal-non-resumable-closure 2")) # Marshal closure over currently alive fiber # issue #317 - 7c4ffe9b9 (do (defn f1 [a] (defn f1 [] (++ (a 0))) (defn f2 [] (++ (a 0))) (marshal [f1 f2] make-image-dict)) (def [f1 f2] (unmarshal (f1 @[0]) load-image-dict)) (assert (= 1 (f1)) "marshal-live-closure 1") (assert (= 2 (f2)) "marshal-live-closure 2")) (do (var a 1) (defn b [x] (+ a x)) (def c (unmarshal (marshal b))) (assert (= 2 (c 1)) "marshal-on-stack-closure 1")) # Issue #336 cases - don't segfault # b145d4786 (assert-error "unmarshal errors 1" (unmarshal @"\xd6\xb9\xb9")) (assert-error "unmarshal errors 2" (unmarshal @"\xd7bc")) # 5bbd50785 (assert-error "unmarshal errors 3" (unmarshal "\xd3\x01\xd9\x01\x62\xcf\x03\x78\x79\x7a" load-image-dict)) # fcc610f53 (assert-error "unmarshal errors 4" (unmarshal @"\xD7\xCD\0e/p\x98\0\0\x03\x01\x01\x01\x02\0\0\x04\0\xCEe/p../tools \0\0\0/afl\0\0\x01\0erate\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE \xA8\xDE\xDE\xDE\xDE\xDE\xDE\0\0\0\xDE\xDE_unmarshal_testcase3.ja neldb\0\0\0\xD8\x05printG\x01\0\xDE\xDE\xDE'\x03\0marshal_tes/\x02 \0\0\0\0\0*\xFE\x01\04\x02\0\0'\x03\0\r\0\r\0\r\0\r" load-image-dict)) # XXX: still needed? see 72beeeea (gccollect) # ev/chan marshalling (compwhen (dyn 'ev/chan) (def chan (ev/chan 10)) (ev/give chan chan) (def newchan (unmarshal (marshal chan))) (def item (ev/take newchan)) (assert (= item newchan) "ev/chan marshalling")) # Issue #1488 - marshalling weak values (testmarsh (array/weak 10) "marsh array/weak") (testmarsh (table/weak-keys 10) "marsh table/weak-keys") (testmarsh (table/weak-values 10) "marsh table/weak-values") (testmarsh (table/weak 10) "marsh table/weak") # Now check that gc works with weak containers after marshalling # Turn off automatic GC for testing weak references (gcsetinterval 0x7FFFFFFF) # array (def a (array/weak 1)) (array/push a @"") (assert (= 1 (length a)) "array/weak marsh 1") (def aclone (-> a marshal unmarshal)) (assert (= 1 (length aclone)) "array/weak marsh 2") (gccollect) (assert (= 1 (length aclone)) "array/weak marsh 3") (assert (= 1 (length a)) "array/weak marsh 4") (assert (= nil (get a 0)) "array/weak marsh 5") (assert (= nil (get aclone 0)) "array/weak marsh 6") (assert (deep= a aclone) "array/weak marsh 7") # table weak keys and values (def t (table/weak 1)) (def keep-key :key) (def keep-value :value) (put t :abc @"") (put t :key :value) (assert (= 2 (length t)) "table/weak marsh 1") (def tclone (-> t marshal unmarshal)) (assert (= 2 (length tclone)) "table/weak marsh 2") (gccollect) (assert (= 1 (length tclone)) "table/weak marsh 3") (assert (= 1 (length t)) "table/weak marsh 4") (assert (= keep-value (get t keep-key)) "table/weak marsh 5") (assert (= keep-value (get tclone keep-key)) "table/weak marsh 6") (assert (deep= t tclone) "table/weak marsh 7") # table weak keys (def t (table/weak-keys 1)) (put t @"" keep-value) (put t :key @"") (assert (= 2 (length t)) "table/weak-keys marsh 1") (def tclone (-> t marshal unmarshal)) (assert (= 2 (length tclone)) "table/weak-keys marsh 2") (gccollect) (assert (= 1 (length tclone)) "table/weak-keys marsh 3") (assert (= 1 (length t)) "table/weak-keys marsh 4") (assert (deep= t tclone) "table/weak-keys marsh 5") # table weak values (def t (table/weak-values 1)) (put t @"" keep-value) (put t :key @"") (assert (= 2 (length t)) "table/weak-values marsh 1") (def tclone (-> t marshal unmarshal)) (assert (= 2 (length tclone)) "table/weak-values marsh 2") (gccollect) (assert (= 1 (length t)) "table/weak-value marsh 3") (assert (deep= (freeze t) (freeze tclone)) "table/weak-values marsh 4") # tables with prototypes (def t (table/weak-values 1)) (table/setproto t @{:abc 123}) (put t @"" keep-value) (put t :key @"") (assert (= 2 (length t)) "marsh weak tables with prototypes 1") (def tclone (-> t marshal unmarshal)) (assert (= 2 (length tclone)) "marsh weak tables with prototypes 2") (gccollect) (assert (= 1 (length t)) "marsh weak tables with prototypes 3") (assert (deep= (freeze t) (freeze tclone)) "marsh weak tables with prototypes 4") (assert (deep= (getproto t) (getproto tclone)) "marsh weak tables with prototypes 5") (end-suite) janet-1.41.2/test/suite-math.janet000066400000000000000000000045011514534607600167750ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # First commit removing the integer number type # 6b95326d7 (assert (= 400 (math/sqrt 160000)) "sqrt(160000)=400") # RNGs # aee168721 (defn test-rng [rng] (assert (all identity (seq [i :range [0 1000]] (<= (math/rng-int rng i) i))) "math/rng-int test") (assert (all identity (seq [_ :range [0 1000]] (def x (math/rng-uniform rng)) (and (>= x 0) (< x 1)))) "math/rng-uniform test")) (def seedrng (math/rng 123)) (for _ 0 75 (test-rng (math/rng (:int seedrng)))) # 70328437f (assert (deep-not= (-> 123 math/rng (:buffer 16)) (-> 456 math/rng (:buffer 16))) "math/rng-buffer 1") (assert-no-error "math/rng-buffer 2" (math/seedrandom "abcdefg")) # 027b2a8 (defn assert-many [f n e] (var good true) (loop [_ :range [0 n]] (if (not (f)) (set good false))) (assert good e)) (assert-many (fn [] (>= 1 (math/random) 0)) 200 "(random) between 0 and 1") # 06aa0a124 (assert (= (math/gcd 462 1071) 21) "math/gcd 1") (assert (= (math/lcm 462 1071) 23562) "math/lcm 1") # math gamma # e6babd8 (assert (< 11899423.08 (math/gamma 11.5) 11899423.085) "math/gamma") (assert (< 2605.1158 (math/log-gamma 500) 2605.1159) "math/log-gamma") (end-suite) janet-1.41.2/test/suite-net.janet000066400000000000000000000027551514534607600166430ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose & contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. # Expand on ev testing with some extra network protocol testing. (import ./helper :prefix "" :exit true) (start-suite) # Smoke (assert true) # Raw socket testing (def s (net/socket :datagram :ipv4)) (assert-no-error "multicast ipv4" (net/setsockopt s :ip-multicast-ttl 255)) #(def s6 (net/socket :datagram :ipv6)) #(assert-no-error "multicast ipv6" (net/setsockopt s6 :ipv6-multicast-hops 255)) (end-suite) janet-1.41.2/test/suite-os.janet000066400000000000000000000165741514534607600165020ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) (def janet (dyn :executable)) (def run (filter next (string/split " " (os/getenv "SUBRUN" "")))) # OS Date test # 719f7ba0c (assert (deep= {:year-day 0 :minutes 30 :month 0 :dst false :seconds 0 :year 2014 :month-day 0 :hours 20 :week-day 3} (os/date 1388608200)) "os/date") # OS mktime test # 3ee43c3ab (assert (= 1388608200 (os/mktime {:year-day 0 :minutes 30 :month 0 :dst false :seconds 0 :year 2014 :month-day 0 :hours 20 :week-day 3})) "os/mktime") (def now (os/time)) (assert (= (os/mktime (os/date now)) now) "UTC os/mktime") (assert (= (os/mktime (os/date now true) true) now) "local os/mktime") (assert (= (os/mktime {:year 1970}) 0) "os/mktime default values") # OS strftime test # 5cd729c4c (assert (= (os/strftime "%Y-%m-%d %H:%M:%S" 0) "1970-01-01 00:00:00") "strftime UTC epoch") (assert (= (os/strftime "%Y-%m-%d %H:%M:%S" 1388608200) "2014-01-01 20:30:00") "strftime january 2014") (assert (= (try (os/strftime "%%%d%t") ([err] err)) "invalid conversion specifier '%t'") "invalid conversion specifier 1") (assert (= (try (os/strftime "%H:%M:%") ([err] err)) "invalid conversion specifier") "invalid conversion specifier 2") # 07db4c530 (os/setenv "TESTENV1" "v1") (os/setenv "TESTENV2" "v2") (assert (= (os/getenv "TESTENV1") "v1") "getenv works") (def environ (os/environ)) (assert (= [(environ "TESTENV1") (environ "TESTENV2")] ["v1" "v2"]) "environ works") # Ensure randomness puts n of pred into our buffer eventually # 0ac5b243c (defn cryptorand-check [n pred] (def max-attempts 10000) (var attempts 0) (while (not= attempts max-attempts) (def cryptobuf (os/cryptorand 10)) (when (= n (count pred cryptobuf)) (break)) (++ attempts)) (not= attempts max-attempts)) (def v (math/rng-int (math/rng (os/time)) 100)) (assert (cryptorand-check 0 |(= $ v)) "cryptorand skips value sometimes") (assert (cryptorand-check 1 |(= $ v)) "cryptorand has value sometimes") (do (def buf (buffer/new-filled 1)) (os/cryptorand 1 buf) (assert (= (in buf 0) 0) "cryptorand doesn't overwrite buffer") (assert (= (length buf) 2) "cryptorand appends to buffer")) (assert-no-error "realtime clock" (os/clock)) (assert-no-error "realtime clock" (os/clock nil)) (assert-no-error "realtime clock" (os/clock nil nil)) # 80db68210 (assert-no-error "realtime clock" (os/clock :realtime)) (assert-no-error "cputime clock" (os/clock :cputime)) (assert-no-error "monotonic clock" (os/clock :monotonic)) (assert-no-error "realtime clock double output" (os/clock nil :double)) (assert-no-error "realtime clock int output" (os/clock nil :int)) (assert-no-error "realtime clock tuple output" (os/clock nil :tuple)) (assert-error "invalid clock" (os/clock :a)) (assert-error "invalid output" (os/clock :realtime :b)) (assert-error "invalid clock and output" (os/clock :a :b)) (def before (os/clock :monotonic)) (def after (os/clock :monotonic)) (assert (>= after before) "monotonic clock is monotonic") # Perm strings # a0d61e45d (assert (= (os/perm-int "rwxrwxrwx") 8r777) "perm 1") (assert (= (os/perm-int "rwxr-xr-x") 8r755) "perm 2") (assert (= (os/perm-int "rw-r--r--") 8r644) "perm 3") (assert (= (band (os/perm-int "rwxrwxrwx") 8r077) 8r077) "perm 4") (assert (= (band (os/perm-int "rwxr-xr-x") 8r077) 8r055) "perm 5") (assert (= (band (os/perm-int "rw-r--r--") 8r077) 8r044) "perm 6") (assert (= (os/perm-string 8r777) "rwxrwxrwx") "perm 7") (assert (= (os/perm-string 8r755) "rwxr-xr-x") "perm 8") (assert (= (os/perm-string 8r644) "rw-r--r--") "perm 9") # Pipes (assert-no-error (os/pipe)) (assert-no-error (os/pipe :RW)) (assert-no-error (os/pipe :R)) (assert-no-error (os/pipe :W)) # os/execute with environment variables # issue #636 - 7e2c433ab (assert (= 0 (os/execute [;run janet "-e" "(+ 1 2 3)"] :pe (merge (os/environ) {"HELLO" "WORLD"}))) "os/execute with env") # os/execute with empty environment # pr #1686 # native MinGW can't find system DLLs without PATH and so fails (assert (= (if (and (= :mingw (os/which)) (nil? (os/stat "C:\\windows\\system32\\wineboot.exe"))) -1073741515 0) (os/execute [;run janet "-e" "(+ 1 2 3)"] :pe {})) "os/execute with minimal env") # os/execute regressions # 427f7c362 (for i 0 10 (assert (= i (os/execute [;run janet "-e" (string/format "(os/exit %d)" i)] :p)) (string "os/execute " i))) # os/execute IO redirection (assert-no-error "IO redirection" (defn devnull [] (def os (os/which)) (def path (if (or (= os :mingw) (= os :windows)) "NUL" "/dev/null")) (os/open path :w)) (with [dn (devnull)] (os/execute [;run janet "-e" "(print :foo) (eprint :bar)"] :px {:out dn :err dn}))) # os/execute IO redirection with more windows flags (assert-no-error "IO redirection more windows flags" (defn devnull [] (def os (os/which)) (def path (if (or (= os :mingw) (= os :windows)) "NUL" "/dev/null")) (os/open path (if (= os :windows) :wWI :wW))) (with [dn (devnull)] (os/execute [;run janet "-e" "(print :foo) (eprint :bar)"] :px {:out dn :err dn}))) # Issue 16922 (assert-error "os/realpath errors when path does not exist" (os/realpath "abc123def456")) # os/which changes (assert (os/which (os/which)) "os/which 1 arg") (assert (not (os/which :gobbledegook)) "os/which 2") (end-suite) janet-1.41.2/test/suite-parse.janet000066400000000000000000000154621514534607600171660ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # 7e46ead2f (assert (not false) "false literal") (assert true "true literal") (assert (not nil) "nil literal") (assert (= '(1 2 3) (quote (1 2 3)) (tuple 1 2 3)) "quote shorthand") # String literals # 45f8db0 (assert (= "abcd" "\x61\x62\x63\x64") "hex escapes") (assert (= "\e" "\x1B") "escape character") (assert (= "\x09" "\t") "tab character") # Long strings # 7e6342720 (assert (= "hello, world" `hello, world`) "simple long string") (assert (= "hello, \"world\"" `hello, "world"`) "long string with embedded quotes") (assert (= "hello, \\\\\\ \"world\"" `hello, \\\ "world"`) "long string with embedded quotes and backslashes") # # Longstring indentation # # 7aa4241 (defn reindent "Reindent the contents of a longstring as the Janet parser would. This include removing leading and trailing newlines." [text indent] # Detect minimum indent (var rewrite true) (each index (string/find-all "\n" text) (for i (+ index 1) (+ index indent 1) (case (get text i) nil (break) (chr "\r") (if-not (= (chr "\n") (get text (inc i))) (set rewrite false)) (chr "\n") (break) (chr " ") nil (set rewrite false)))) # Only re-indent if no dedented characters. (def str (if rewrite (peg/replace-all ~(* '(* (? "\r") "\n") (between 0 ,indent " ")) (fn [_mtch eol] eol) text) text)) (def first-eol (cond (string/has-prefix? "\r\n" str) :crlf (string/has-prefix? "\n" str) :lf)) (def last-eol (cond (string/has-suffix? "\r\n" str) :crlf (string/has-suffix? "\n" str) :lf)) (string/slice str (case first-eol :crlf 2 :lf 1 0) (case last-eol :crlf -3 :lf -2))) (defn reindent-reference "Same as reindent but use parser functionality. Useful for validating conformance." [text indent] (if (empty? text) (break text)) (def source-code (string (string/repeat " " indent) "``````" text "``````")) (parse source-code)) (var indent-counter 0) (defn check-indent [text indent] (++ indent-counter) (let [a (reindent text indent) b (reindent-reference text indent)] (assert (= a b) (string/format "reindent: %q, parse: %q (indent-test #%d with indent of %d)" a b indent-counter indent) ))) # Unix EOLs (check-indent "" 0) (check-indent "\n" 0) (check-indent "\n" 1) (check-indent "\n\n" 0) (check-indent "\n\n" 1) (check-indent "\nHello, world!" 0) (check-indent "\nHello, world!" 1) (check-indent "Hello, world!" 0) (check-indent "Hello, world!" 1) (check-indent "\n Hello, world!" 4) (check-indent "\n Hello, world!\n" 4) (check-indent "\n Hello, world!\n " 4) (check-indent "\n Hello, world!\n " 4) (check-indent "\n Hello, world!\n dedented text\n " 4) (check-indent "\n Hello, world!\n indented text\n " 4) # Windows EOLs (check-indent "\r\n" 0) (check-indent "\r\n" 1) (check-indent "\r\n\r\n" 0) (check-indent "\r\n\r\n" 1) (check-indent "\r\nHello, world!" 0) (check-indent "\r\nHello, world!" 1) (check-indent "\r\n Hello, world!\r\n " 4) (check-indent "\r\n Hello, world!\r\n " 4) (check-indent "\r\n Hello, world!\r\n dedented text\r\n " 4) (check-indent "\r\n Hello, world!\r\n indented text\r\n " 4) # Symbols with @ character # d68eae9 (def @ 1) (assert (= @ 1) "@ symbol") (def @-- 2) (assert (= @-- 2) "@-- symbol") (def @hey 3) (assert (= @hey 3) "@hey symbol") # Parser clone # 43520ac67 (def p (parser/new)) (assert (= 7 (parser/consume p "(1 2 3 ")) "parser 1") (def p2 (parser/clone p)) (parser/consume p2 ") 1 ") (parser/consume p ") 1 ") (assert (deep= (parser/status p) (parser/status p2)) "parser 2") (assert (deep= (parser/state p) (parser/state p2)) "parser 3") # Parser errors # 976dfc719 (defn parse-error [input] (def p (parser/new)) (parser/consume p input) (parser/error p)) # Invalid utf-8 sequences (assert (not= nil (parse-error @"\xc3\x28")) "reject invalid utf-8 symbol") (assert (not= nil (parse-error @":\xc3\x28")) "reject invalid utf-8 keyword") # Parser line and column numbers # 77b79e989 (defn parser-location [input &opt location] (def p (parser/new)) (parser/consume p input) (if location (parser/where p ;location) (parser/where p))) (assert (= [1 7] (parser-location @"(+ 1 2)")) "parser location 1") (assert (= [5 7] (parser-location @"(+ 1 2)" [5])) "parser location 2") (assert (= [10 10] (parser-location @"(+ 1 2)" [10 10])) "parser location 3") # Issue #861 - should be valgrind clean # 39c6be7cb (def step1 "(a b c d)\n") (def step2 "(a b)\n") (def p1 (parser/new)) (parser/state p1) (parser/consume p1 step1) (loop [_ :iterate (parser/produce p1)]) (parser/state p1) (def p2 (parser/clone p1)) (parser/state p2) (parser/consume p2 step2) (loop [_ :iterate (parser/produce p2)]) (parser/state p2) # parser delimiter errors (defn test-error [delim fmt] (def p (parser/new)) (parser/consume p delim) (parser/eof p) (def msg (string/format fmt delim)) (assert (= (parser/error p) msg) "delimiter error")) (each c [ "(" "{" "[" "\"" "``" ] (test-error c "unexpected end of source, %s opened at line 1, column 1")) # parser/insert (def p (parser/new)) (parser/consume p "(") (parser/insert p "hello") (parser/consume p ")") (assert (= (parser/produce p) ["hello"])) (def p (parser/new)) (parser/consume p `("hel`) (parser/insert p `lo`) (parser/consume p `")`) (assert (= (parser/produce p) ["hello"])) # Hex floats (assert (= math/pi +0x1.921fb54442d18p+0001)) (assert (= math/int-max +0x1.ffff_ffff_ffff_ffp+0052)) (assert (= math/int-min -0x1.ffff_ffff_ffff_ffp+0052)) (assert (= 1 0x1P0)) (assert (= 2 0x1P1)) (assert (= -2 -0x1p1)) (assert (= -0.5 -0x1p-1)) (end-suite) janet-1.41.2/test/suite-peg.janet000066400000000000000000000721411514534607600166240ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Peg # 83f4a11bf (defn check-match [pat text should-match] (def result (peg/match pat text)) (assert (= (not should-match) (not result)) (string "check-match " text))) # 798c88b4c (defn check-deep [pat text what] (def result (peg/match pat text)) (assert (deep= result what) (string "check-deep " text))) # Just numbers # 83f4a11bf (check-match '(* 4 -1) "abcd" true) (check-match '(* 4 -1) "abc" false) (check-match '(* 4 -1) "abcde" false) # Simple pattern # 83f4a11bf (check-match '(* (some (range "az" "AZ")) -1) "hello" true) (check-match '(* (some (range "az" "AZ")) -1) "hello world" false) (check-match '(* (some (range "az" "AZ")) -1) "1he11o" false) (check-match '(* (some (range "az" "AZ")) -1) "" false) # Pre compile # ff0d3a008 (def pegleg (peg/compile '{:item "abc" :main (* :item "," :item -1)})) (peg/match pegleg "abc,abc") # Bad Grammars # 192705113 (assert-error "peg/compile error 1" (peg/compile nil)) (assert-error "peg/compile error 2" (peg/compile @{})) (assert-error "peg/compile error 3" (peg/compile '{:a "abc" :b "def"})) (assert-error "peg/compile error 4" (peg/compile '(blarg "abc"))) (assert-error "peg/compile error 5" (peg/compile '(1 2 3))) # IP address # 40845b5c1 (def ip-address '{:d (range "09") :0-4 (range "04") :0-5 (range "05") :byte (+ (* "25" :0-5) (* "2" :0-4 :d) (* "1" :d :d) (between 1 2 :d)) :main (* :byte "." :byte "." :byte "." :byte)}) (check-match ip-address "10.240.250.250" true) (check-match ip-address "0.0.0.0" true) (check-match ip-address "1.2.3.4" true) (check-match ip-address "256.2.3.4" false) (check-match ip-address "256.2.3.2514" false) # Substitution test with peg # d7626f8c5 (def grammar '(accumulate (any (+ (/ "dog" "purple panda") (<- 1))))) (defn try-grammar [text] (assert (= (string/replace-all "dog" "purple panda" text) (0 (peg/match grammar text))) text)) (try-grammar "i have a dog called doug the dog. he is good.") (try-grammar "i have a dog called doug the dog. he is a good boy.") (try-grammar "i have a dog called doug the do") (try-grammar "i have a dog called doug the dog") (try-grammar "i have a dog called doug the dogg") (try-grammar "i have a dog called doug the doggg") (try-grammar "i have a dog called doug the dogggg") # Peg CSV test # 798c88b4c (def csv '{:field (+ (* `"` (% (any (+ (<- (if-not `"` 1)) (* (constant `"`) `""`)))) `"`) (<- (any (if-not (set ",\n") 1)))) :main (* :field (any (* "," :field)) (+ "\n" -1))}) (defn check-csv [str res] (check-deep csv str res)) (check-csv "1,2,3" @["1" "2" "3"]) (check-csv "1,\"2\",3" @["1" "2" "3"]) (check-csv ``1,"1""",3`` @["1" "1\"" "3"]) # Nested Captures # 798c88b4c (def grmr '(capture (* (capture "a") (capture 1) (capture "c")))) (check-deep grmr "abc" @["a" "b" "c" "abc"]) (check-deep grmr "acc" @["a" "c" "c" "acc"]) # Functions in grammar # 798c88b4c (def grmr-triple ~(% (any (/ (<- 1) ,(fn [x] (string x x x)))))) (check-deep grmr-triple "abc" @["aaabbbccc"]) (check-deep grmr-triple "" @[""]) (check-deep grmr-triple " " @[" "]) (def counter ~(/ (group (any (<- 1))) ,length)) (check-deep counter "abcdefg" @[7]) # Capture Backtracking # ff0d3a008 (check-deep '(+ (* (capture "c") "d") "ce") "ce" @[]) # Matchtime capture # 192705113 (def scanner (peg/compile ~(cmt (capture (some 1)) ,scan-number))) (check-deep scanner "123" @[123]) (check-deep scanner "0x86" @[0x86]) (check-deep scanner "-1.3e-7" @[-1.3e-7]) (check-deep scanner "123A" nil) # Recursive grammars # 170e785b7 (def g '{:main (+ (* "a" :main "b") "c")}) (check-match g "c" true) (check-match g "acb" true) (check-match g "aacbb" true) (check-match g "aadbb" false) # Back reference # d0ec89c7c (def wrapped-string ~{:pad (any "=") :open (* "[" (<- :pad :n) "[") :close (* "]" (cmt (* (-> :n) (<- :pad)) ,=) "]") :main (* :open (any (if-not :close 1)) :close -1)}) (check-match wrapped-string "[[]]" true) (check-match wrapped-string "[==[a]==]" true) (check-match wrapped-string "[==[]===]" false) (check-match wrapped-string "[[blark]]" true) (check-match wrapped-string "[[bl[ark]]" true) (check-match wrapped-string "[[bl]rk]]" true) (check-match wrapped-string "[[bl]rk]] " false) (check-match wrapped-string "[=[bl]]rk]=] " false) (check-match wrapped-string "[=[bl]==]rk]=] " false) (check-match wrapped-string "[===[]==]===]" true) (def janet-longstring ~{:delim (some "`") :open (capture :delim :n) :close (cmt (* (not (> -1 "`")) (-> :n) (<- (backmatch :n))) ,=) :main (* :open (any (if-not :close 1)) :close -1)}) (check-match janet-longstring "`john" false) (check-match janet-longstring "abc" false) (check-match janet-longstring "` `" true) (check-match janet-longstring "` `" true) (check-match janet-longstring "`` ``" true) (check-match janet-longstring "``` `` ```" true) (check-match janet-longstring "`` ```" false) (check-match janet-longstring "`a``b`" false) # Line and column capture # 776ce586b (def line-col (peg/compile '(any (* (line) (column) 1)))) (check-deep line-col "abcd" @[1 1 1 2 1 3 1 4]) (check-deep line-col "" @[]) (check-deep line-col "abcd\n" @[1 1 1 2 1 3 1 4 1 5]) (check-deep line-col "abcd\nz" @[1 1 1 2 1 3 1 4 1 5 2 1]) # Backmatch # 711fe64a5 (def backmatcher-1 '(* (capture (any "x") :1) "y" (backmatch :1) -1)) (check-match backmatcher-1 "y" true) (check-match backmatcher-1 "xyx" true) (check-match backmatcher-1 "xxxxxxxyxxxxxxx" true) (check-match backmatcher-1 "xyxx" false) (check-match backmatcher-1 (string (string/repeat "x" 73) "y") false) (check-match backmatcher-1 (string (string/repeat "x" 10000) "y") false) (check-match backmatcher-1 (string (string/repeat "x" 10000) "y" (string/repeat "x" 10000)) true) (def backmatcher-2 '(* '(any "x") "y" (backmatch) -1)) (check-match backmatcher-2 "y" true) (check-match backmatcher-2 "xyx" true) (check-match backmatcher-2 "xxxxxxxyxxxxxxx" true) (check-match backmatcher-2 "xyxx" false) (check-match backmatcher-2 (string (string/repeat "x" 73) "y") false) (check-match backmatcher-2 (string (string/repeat "x" 10000) "y") false) (check-match backmatcher-2 (string (string/repeat "x" 10000) "y" (string/repeat "x" 10000)) true) (def longstring-2 '(* '(some "`") (some (if-not (backmatch) 1)) (backmatch) -1)) (check-match longstring-2 "`john" false) (check-match longstring-2 "abc" false) (check-match longstring-2 "` `" true) (check-match longstring-2 "` `" true) (check-match longstring-2 "`` ``" true) (check-match longstring-2 "``` `` ```" true) (check-match longstring-2 "`` ```" false) # Optional # 4eeadd746 (check-match '(* (opt "hi") -1) "" true) (check-match '(* (opt "hi") -1) "hi" true) (check-match '(* (opt "hi") -1) "no" false) (check-match '(* (? "hi") -1) "" true) (check-match '(* (? "hi") -1) "hi" true) (check-match '(* (? "hi") -1) "no" false) # Drop # b4934cedd (check-deep '(drop '"hello") "hello" @[]) (check-deep '(drop "hello") "hello" @[]) # Add bytecode verification for peg unmarshaling # e88a9af2f # This should be valgrind clean. (var pegi 3) (defn marshpeg [p] (assert (-> p peg/compile marshal unmarshal) (string "peg marshal " (++ pegi)))) (marshpeg '(* 1 2 (set "abcd") "asdasd" (+ "." 3))) (marshpeg '(% (* (+ 1 2 3) (* "drop" "bear") '"hi"))) (marshpeg '(> 123 "abcd")) (marshpeg '{:main (* 1 "hello" :main)}) (marshpeg '(range "AZ")) (marshpeg '(if-not "abcdf" 123)) (marshpeg '(error ($))) (marshpeg '(* "abcd" (constant :hi))) (marshpeg ~(/ "abc" ,identity)) (marshpeg '(if-not "abcdf" 123)) (marshpeg ~(cmt "abcdf" ,identity)) (marshpeg '(group "abc")) (marshpeg '(sub "abcdf" "abc")) (marshpeg '(* (sub 1 1))) (marshpeg '(split "," (+ "a" "b" "c"))) (marshpeg "") (marshpeg 1) (marshpeg 0) (marshpeg -1) (marshpeg '(drop 1)) (marshpeg '(accumulate 1)) # Peg swallowing errors # 159651117 (assert (try (peg/match ~(/ '1 ,(fn [x] (nil x))) "x") ([err] err)) "errors should not be swallowed") (assert (try ((fn [x] (nil x))) ([err] err)) "errors should not be swallowed 2") # Check for bad memoization (+ :a) should mean different things in # different contexts # 8bc8709d0 (def redef-a ~{:a "abc" :c (+ :a) :main (* :c {:a "def" :main (+ :a)} -1)}) (check-match redef-a "abcdef" true) (check-match redef-a "abcabc" false) (check-match redef-a "defdef" false) # 54a04b589 (def redef-b ~{:pork {:pork "beef" :main (+ -1 (* 1 :pork))} :main :pork}) (check-match redef-b "abeef" true) (check-match redef-b "aabeef" false) (check-match redef-b "aaaaaa" false) # Integer parsing # 45feb5548 (check-deep '(int 1) "a" @[(chr "a")]) (check-deep '(uint 1) "a" @[(chr "a")]) (check-deep '(int-be 1) "a" @[(chr "a")]) (check-deep '(uint-be 1) "a" @[(chr "a")]) (check-deep '(int 1) "\xFF" @[-1]) (check-deep '(uint 1) "\xFF" @[255]) (check-deep '(int-be 1) "\xFF" @[-1]) (check-deep '(uint-be 1) "\xFF" @[255]) (check-deep '(int 2) "\xFF\x7f" @[0x7fff]) (check-deep '(int-be 2) "\x7f\xff" @[0x7fff]) (check-deep '(uint 2) "\xff\x7f" @[0x7fff]) (check-deep '(uint-be 2) "\x7f\xff" @[0x7fff]) (check-deep '(uint-be 2) "\x7f\xff" @[0x7fff]) (when-let [u64 int/u64 i64 int/s64] (check-deep '(uint 8) "\xff\x7f\x00\x00\x00\x00\x00\x00" @[(u64 0x7fff)]) (check-deep '(int 8) "\xff\x7f\x00\x00\x00\x00\x00\x00" @[(i64 0x7fff)]) (check-deep '(uint 7) "\xff\x7f\x00\x00\x00\x00\x00" @[(u64 0x7fff)]) (check-deep '(int 7) "\xff\x7f\x00\x00\x00\x00\x00" @[(i64 0x7fff)])) (check-deep '(* (int 2) -1) "123" nil) # to/thru bug # issue #640 - 742469a8b (check-deep '(to -1) "aaaa" @[]) (check-deep '(thru -1) "aaaa" @[]) (check-deep ''(to -1) "aaaa" @["aaaa"]) (check-deep ''(thru -1) "aaaa" @["aaaa"]) (check-deep '(to "b") "aaaa" nil) (check-deep '(thru "b") "aaaa" nil) # unref # 96513665d (def grammar (peg/compile ~{:main (* :tagged -1) :tagged (unref (replace (* :open-tag :value :close-tag) ,struct)) :open-tag (* (constant :tag) "<" (capture :w+ :tag-name) ">") :value (* (constant :value) (group (any (+ :tagged :untagged)))) :close-tag (* "") :untagged (capture (any (if-not "<" 1)))})) (check-deep grammar "

foobar

" @[{:tag "p" :value @[{:tag "em" :value @["foobar"]}]}]) (check-deep grammar "

foobar

" @[{:tag "p" :value @["foobar"]}]) # Using a large test grammar # cf05ff610 (def- specials {'fn true 'var true 'do true 'while true 'def true 'splice true 'set true 'unquote true 'quasiquote true 'quote true 'if true}) (defn- check-number [text] (and (scan-number text) text)) (defn capture-sym [text] (def sym (symbol text)) [(if (or (root-env sym) (specials sym)) :coresym :symbol) text]) (def grammar ~{:ws (set " \v\t\r\f\n\0") :readermac (set "';~,") :symchars (+ (range "09" "AZ" "az" "\x80\xFF") (set "!$%&*+-./:@^_|")) :token (some :symchars) :hex (range "09" "af" "AF") :escape (* "\\" (+ (set `"'0?\abefnrtvz`) (* "x" :hex :hex) (error (constant "bad hex escape")))) :comment (/ '(* "#" (any (if-not (+ "\n" -1) 1))) (constant :comment)) :symbol (/ ':token ,capture-sym) :keyword (/ '(* ":" (any :symchars)) (constant :keyword)) :constant (/ '(+ "true" "false" "nil") (constant :constant)) :bytes (* "\"" (any (+ :escape (if-not "\"" 1))) "\"") :string (/ ':bytes (constant :string)) :buffer (/ '(* "@" :bytes) (constant :string)) :long-bytes {:delim (some "`") :open (capture :delim :n) :close (cmt (* (not (> -1 "`")) (-> :n) '(backmatch :n)) ,=) :main (drop (* :open (any (if-not :close 1)) :close))} :long-string (/ ':long-bytes (constant :string)) :long-buffer (/ '(* "@" :long-bytes) (constant :string)) :number (/ (cmt ':token ,check-number) (constant :number)) :raw-value (+ :comment :constant :number :keyword :string :buffer :long-string :long-buffer :parray :barray :ptuple :btuple :struct :dict :symbol) :value (* (? '(some (+ :ws :readermac))) :raw-value '(any :ws)) :root (any :value) :root2 (any (* :value :value)) :ptuple (* '"(" :root (+ '")" (error ""))) :btuple (* '"[" :root (+ '"]" (error ""))) :struct (* '"{" :root2 (+ '"}" (error ""))) :parray (* '"@" :ptuple) :barray (* '"@" :btuple) :dict (* '"@" :struct) :main (+ :root (error ""))}) (def p (peg/compile grammar)) # Just make sure is valgrind clean. (def p (-> p make-image load-image)) (assert (peg/match p "abc") "complex peg grammar 1") (assert (peg/match p "[1 2 3 4]") "complex peg grammar 2") ### ### Compiling brainfuck to Janet. ### # 20d5d560f (def- bf-peg "Peg for compiling brainfuck into a Janet source ast." (peg/compile ~{:+ (/ '(some "+") ,(fn [x] ~(+= (DATA POS) ,(length x)))) :- (/ '(some "-") ,(fn [x] ~(-= (DATA POS) ,(length x)))) :> (/ '(some ">") ,(fn [x] ~(+= POS ,(length x)))) :< (/ '(some "<") ,(fn [x] ~(-= POS ,(length x)))) :. (* "." (constant (prinf "%c" (get DATA POS)))) :loop (/ (* "[" :main "]") ,(fn [& captures] ~(while (not= (get DATA POS) 0) ,;captures))) :main (any (+ :s :loop :+ :- :> :< :.))})) (defn bf "Run brainfuck." [text] (eval ~(let [DATA (array/new-filled 100 0)] (var POS 50) ,;(peg/match bf-peg text)))) (defn test-bf "Test some bf for expected output." [input output] (def b @"") (with-dyns [:out b] (bf input)) (assert (= (string output) (string b)) (string "bf input '" input "' failed, expected " (describe output) ", got " (describe (string b)) "."))) (test-bf (string "++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]" ">>.>---.+++++++..+++.>>.<-.<.+++.------.--------" ".>>+.>++.") "Hello World!\n") (test-bf (string ">++++++++" "[-<+++++++++>]<.>>+>-[+]++>++>+++[>[->+++<<+++>]<<]" ">-----.>->+++..+++.>-.<<+[>[+>+]>>]<--------------" ".>>.+++.------.--------.>+.>+.") "Hello World!\n") (test-bf (string "+[+[<<<+>>>>]+<-<-<<<+<++]<<.<++.<++..+++.<<++.<---" ".>>.>.+++.------.>-.>>--.") "Hello, World!") # Regression test # issue #300 - 714bd61d5 # Just don't segfault (assert (peg/match '{:main (replace "S" {"S" :spade})} "S7") "regression #300") # Lenprefix rule # 8b5bcaee3 (def peg (peg/compile ~(* (lenprefix (/ (* '(any (if-not ":" 1)) ":") ,scan-number) 1) -1))) (assert (peg/match peg "5:abcde") "lenprefix 1") (assert (not (peg/match peg "5:abcdef")) "lenprefix 2") (assert (not (peg/match peg "5:abcd")) "lenprefix 3") # Packet capture # 8b5bcaee3 (def peg2 (peg/compile ~{# capture packet length in tag :header-len :packet-header (* (/ ':d+ ,scan-number :header-len) ":") # capture n bytes from a backref :header-len :packet-body '(lenprefix (-> :header-len) 1) # header, followed by body, and drop the :header-len capture :packet (/ (* :packet-header :packet-body) ,|$1) # any exact sequence of packets (no extra characters) :main (* (any :packet) -1)})) (assert (deep= @["a" "bb" "ccc"] (peg/match peg2 "1:a2:bb3:ccc")) "lenprefix 4") (assert (deep= @["a" "bb" "cccccc"] (peg/match peg2 "1:a2:bb6:cccccc")) "lenprefix 5") (assert (= nil (peg/match peg2 "1:a2:bb:5:cccccc")) "lenprefix 6") (assert (= nil (peg/match peg2 "1:a2:bb:7:cccccc")) "lenprefix 7") # Issue #412 # 677737d34 (assert (peg/match '(* "a" (> -1 "a") "b") "abc") "lookhead does not move cursor") # 6d096551f (def peg3 ~{:main (* "(" (thru ")"))}) (def peg4 (peg/compile ~(* (thru "(") '(to ")")))) (assert (peg/match peg3 "(12345)") "peg thru 1") (assert (not (peg/match peg3 " (12345)")) "peg thru 2") (assert (not (peg/match peg3 "(12345")) "peg thru 3") (assert (= "abc" (0 (peg/match peg4 "123(abc)"))) "peg thru/to 1") (assert (= "abc" (0 (peg/match peg4 "(abc)"))) "peg thru/to 2") (assert (not (peg/match peg4 "123(abc")) "peg thru/to 3") # 86e12369b (def peg5 (peg/compile [3 "abc"])) (assert (:match peg5 "abcabcabc") "repeat alias 1") (assert (:match peg5 "abcabcabcac") "repeat alias 2") (assert (not (:match peg5 "abcabc")) "repeat alias 3") # Peg find and find-all # c26f57362 (def p "/usr/local/bin/janet") (assert (= (peg/find '"n/" p) 13) "peg find 1") (assert (not (peg/find '"t/" p)) "peg find 2") (assert (deep= (peg/find-all '"/" p) @[0 4 10 14]) "peg find-all") # Peg replace and replace-all # e548e1f6e (defn check-replacer [x y z] (assert (= (string/replace x y z) (string (peg/replace x y z))) "replacer test replace") (assert (= (string/replace-all x y z) (string (peg/replace-all x y z))) "replacer test replace-all")) (check-replacer "abc" "Z" "abcabcabcabasciabsabc") (check-replacer "abc" "Z" "") (check-replacer "aba" "ZZZZZZ" "ababababababa") (check-replacer "aba" "" "ababababababa") # 485099fd6 (check-replacer "aba" string/ascii-upper "ababababababa") (check-replacer "aba" 123 "ababababababa") (assert (= (string (peg/replace-all ~(set "ab") string/ascii-upper "abcaa")) "ABcAA") "peg/replace-all cfunction") (assert (= (string (peg/replace-all ~(set "ab") |$ "abcaa")) "abcaa") "peg/replace-all function") # 9dc7e8ed3 (defn peg-test [name f peg subst text expected] (assert (= (string (f peg subst text)) expected) name)) (peg-test "peg/replace has access to captures" peg/replace ~(sequence "." (capture (set "ab"))) (fn [str char] (string/format "%s -> %s, " str (string/ascii-upper char))) ".a.b.c" ".a -> A, .b.c") (peg-test "peg/replace-all has access to captures" peg/replace-all ~(sequence "." (capture (set "ab"))) (fn [str char] (string/format "%s -> %s, " str (string/ascii-upper char))) ".a.b.c" ".a -> A, .b -> B, .c") # Peg bug # eab5f67c5 (assert (deep= @[] (peg/match '(any 1) @"")) "peg empty pattern 1") (assert (deep= @[] (peg/match '(any 1) (buffer))) "peg empty pattern 2") (assert (deep= @[] (peg/match '(any 1) "")) "peg empty pattern 3") (assert (deep= @[] (peg/match '(any 1) (string))) "peg empty pattern 4") (assert (deep= @[] (peg/match '(* "test" (any 1)) @"test")) "peg empty pattern 5") (assert (deep= @[] (peg/match '(* "test" (any 1)) (buffer "test"))) "peg empty pattern 6") # number pattern # cccbdc164 (assert (deep= @[111] (peg/match '(number :d+) "111")) "simple number capture 1") (assert (deep= @[255] (peg/match '(number :w+) "0xff")) "simple number capture 2") # Marshal and unmarshal pegs # 446ab037b (def p (-> "abcd" peg/compile marshal unmarshal)) (assert (peg/match p "abcd") "peg marshal 1") (assert (peg/match p "abcdefg") "peg marshal 2") (assert (not (peg/match p "zabcdefg")) "peg marshal 3") # to/thru bug # issue #971 - a895219d2 (def pattern (peg/compile '{:dd (sequence :d :d) :sep (set "/-") :date (sequence :dd :sep :dd) :wsep (some (set " \t")) :entry (group (sequence (capture :date) :wsep (capture :date))) :main (some (thru :entry))})) (def alt-pattern (peg/compile '{:dd (sequence :d :d) :sep (set "/-") :date (sequence :dd :sep :dd) :wsep (some (set " \t")) :entry (group (sequence (capture :date) :wsep (capture :date))) :main (some (choice :entry 1))})) (def text "1800-10-818-9-818 16/12\n17/12 19/12\n20/12 11/01") (assert (deep= (peg/match pattern text) (peg/match alt-pattern text)) "to/thru bug #971") # 14657a7 (def- sym-prefix-peg (peg/compile ~{:symchar (+ (range "\x80\xff" "AZ" "az" "09") (set "!$%&*+-./:@^_")) :anchor (drop (cmt ($) ,|(= $ 0))) :cap (* (+ (> -1 (not :symchar)) :anchor) (* ($) '(some :symchar))) :recur (+ :cap (> -1 :recur)) :main (> -1 :recur)})) (assert (deep= (peg/match sym-prefix-peg @"123" 3) @[0 "123"]) "peg lookback") (assert (deep= (peg/match sym-prefix-peg @"1234" 4) @[0 "1234"]) "peg lookback 2") # issue #1027 - 356b39c6f (assert (deep= (peg/replace-all '(* (<- 1) 1 (backmatch)) "xxx" "aba cdc efa") @"xxx xxx efa") "peg replace-all 1") # issue #1026 - 9341081a4 (assert (deep= (peg/match '(not (* (constant 7) "a")) "hello") @[]) "peg not") (assert (deep= (peg/match '(if-not (* (constant 7) "a") "hello") "hello") @[]) "peg if-not") (assert (deep= (peg/match '(if-not (drop (* (constant 7) "a")) "hello") "hello") @[]) "peg if-not drop") (assert (deep= (peg/match '(if (not (* (constant 7) "a")) "hello") "hello") @[]) "peg if not") (defn test [name peg input expected] (assert-no-error "compile peg" (peg/compile peg)) (assert-no-error "marshal/unmarshal peg" (-> peg marshal unmarshal)) (assert (deep= (peg/match peg input) expected) name)) (test "sub: matches the same input twice" ~(sub "abcd" "abc") "abcdef" @[]) (test "sub: second pattern cannot match more than the first pattern" ~(sub "abcd" "abcde") "abcdef" nil) (test "sub: fails if first pattern fails" ~(sub "x" "abc") "abcdef" nil) (test "sub: fails if second pattern fails" ~(sub "abc" "x") "abcdef" nil) (test "sub: keeps captures from both patterns" ~(sub '"abcd" '"abc") "abcdef" @["abcd" "abc"]) (test "sub: second pattern can reference captures from first" ~(* (constant 5 :tag) (sub (capture "abc" :tag) (backref :tag))) "abcdef" @[5 "abc" "abc"]) (test "sub: second pattern can't see past what the first pattern matches" ~(sub "abc" (* "abc" -1)) "abcdef" @[]) (test "sub: positions inside second match are still relative to the entire input" ~(* "one\ntw" (sub "o" (* ($) (line) (column)))) "one\ntwo\nthree\n" @[6 2 3]) (test "sub: advances to the end of the first pattern's match" ~(* (sub "abc" "ab") "d") "abcdef" @[]) (test "til: basic matching" ~(til "d" "abc") "abcdef" @[]) (test "til: second pattern can't see past the first occurrence of first pattern" ~(til "d" (* "abc" -1)) "abcdef" @[]) (test "til: fails if first pattern fails" ~(til "x" "abc") "abcdef" nil) (test "til: fails if second pattern fails" ~(til "abc" "x") "abcdef" nil) (test "til: discards captures from initial pattern" ~(til '"d" '"abc") "abcdef" @["abc"]) (test "til: positions inside second match are still relative to the entire input" ~(* "one\ntw" (til 0 (* ($) (line) (column)))) "one\ntwo\nthree\n" @[6 2 3]) (test "til: advances to the end of the first pattern's first occurrence" ~(* (til "d" "ab") "e") "abcdef" @[]) (test "split: basic functionality" ~(split "," '1) "a,b,c" @["a" "b" "c"]) (test "split: drops captures from separator pattern" ~(split '"," '1) "a,b,c" @["a" "b" "c"]) (test "split: can match empty subpatterns" ~(split "," ':w*) ",a,,bar,,,c,," @["" "a" "" "bar" "" "" "c" "" ""]) (test "split: subpattern is limited to only text before the separator" ~(split "," '(to -1)) "a,,bar,c" @["a" "" "bar" "c"]) (test "split: fails if any subpattern fails" ~(split "," '"a") "a,a,b" nil) (test "split: separator does not have to match anything" ~(split "x" '(to -1)) "a,a,b" @["a,a,b"]) (test "split: always consumes entire input" ~(split 1 '"") "abc" @["" "" "" ""]) (test "split: separator can be an arbitrary PEG" ~(split :s+ '(to -1)) "a b c" @["a" "b" "c"]) (test "split: does not advance past the end of the input" ~(* (split "," ':w+) 0) "a,b,c" @["a" "b" "c"]) (test "nth 1" ~{:prefix (number :d+ nil :n) :word '(lenprefix (-> :n) :w) :main (some (nth 1 (* :prefix ":" :word)))} "5:apple6:banana6:cherry" @["apple" "banana" "cherry"]) (test "only-tags 1" ~{:prefix (number :d+ nil :n) :word (capture (lenprefix (-> :n) :w) :W) :main (some (* (only-tags (* :prefix ":" :word)) (-> :W)))} "5:apple6:banana6:cherry" @["apple" "banana" "cherry"]) # Issue #1539 - make sure split with "" doesn't infinite loop/oom (test "issue 1539" ~(split "" (capture (to -1))) "hello there friends" nil) (test "issue 1539 pt. 2" ~(split "," (capture 0)) "abc123,,,," @["" "" "" "" ""]) # Issue #1549 - allow buffers as peg literals (test "issue 1549" ''@"abc123" "abc123" @["abc123"]) # Issue 1554 - 0-width match termination behavior (test "issue 1554 case 1" '(any (> '1)) "abc" @[]) (test "issue 1554 case 2" '(any (? (> '1))) "abc" @[]) (test "issue 1554 case 3" '(any (> (? '1))) "abc" @[]) (test "issue 1554 case 4" '(* "a" (> '1)) "abc" @["b"]) (test "issue 1554 case 5" '(* "a" (? (> '1))) "abc" @["b"]) (test "issue 1554 case 6" '(* "a" (> (? '1))) "abc" @["b"]) (test "issue 1554 case 7" '(between 0 2 (> '1)) "abc" @["a" "a"]) (test "issue 1554 case 8" '(between 2 3 (? (> '1))) "abc" @["a" "a" "a"]) (test "issue 1554 case 9" '(between 0 0 (> (? '1))) "abc" @[]) # Capture Match Flatten (test "capture match splice 1" ~(cms (* 1 '1 1) ,|[$ $ $]) "abc" @["b" "b" "b"]) (test "capture match no splice 1" ~(cmt (* 1 '1 1) ,|[$ $ $]) "abc" @[["b" "b" "b"]]) # Debug and ?? tests. (defn test-stderr [name peg input expected-matches expected-stderr] (with-dyns [:err @""] (test name peg input expected-matches)) (def actual @"") (with-dyns [:err actual *err-color* true] (peg/match peg input)) (assert (deep= (string actual) expected-stderr))) (defn test-stderr-no-color [name peg input expected-matches expected-stderr] (with-dyns [:err @""] (test name peg input expected-matches)) (def actual @"") (with-dyns [:err actual *err-color* false] (peg/match peg input)) (assert (deep= (string actual) expected-stderr))) (test-stderr "?? long form" '(* (debug) "abc") "abc" @[] "?? at [abc] (index 0)\n") (test-stderr "?? short form" '(* (??) "abc") "abc" @[] "?? at [abc] (index 0)\n") (test-stderr "?? end of text" '(* "abc" (??)) "abc" @[] "?? at [] (index 3)\n") (test-stderr "?? between rules" '(* "a" (??) "bc") "abc" @[] "?? at [bc] (index 1)\n") (test-stderr "?? stack display, string" '(* (<- "a") (??) "bc") "abc" @["a"] (string/format "?? at [bc] (index 1)\nstack [1]:\n [0]: %M\n" "a")) (test-stderr "?? stack display, multiple types" '(* (<- "a") (number :d) (constant true) (constant {}) (constant @[]) (??) "bc") "a1bc" @["a" 1 true {} @[]] (string/format "?? at [bc] (index 2)\nstack [5]:\n [0]: %M\n [1]: %M\n [2]: %M\n [3]: %M\n [4]: %M\n" "a" 1 true {} @[])) (marshpeg '(* (??) "abc")) (marshpeg '(* (some (debug)) (??) "abc")) (test-stderr "?? displays when capture fails" '(* '1 (??) "x") "abc" nil (string/format "?? at [bc] (index 1)\nstack [1]:\n [0]: %M\n" "a")) (test-stderr-no-color "?? displays accumuate and tagged captures" '(* '1 '2 (% (* '1 (??) (<- 2 :tag) '3 (backref :tag) (??)))) "aksjndkajsnd" @["a" "ks" "jndkajnd"] (string/replace-all # In case on windows someone messes with line endings. "\r" "" ``` ?? at [ndkajsnd] (index 4) accumulate buffer: @"j" stack [2]: [0]: "a" [1]: "ks" tag stack [3]: [0] tag=0: "a" [1] tag=0: "ks" [2] tag=0: "j" ?? at [snd] (index 9) accumulate buffer: @"jndkajnd" stack [2]: [0]: "a" [1]: "ks" tag stack [6]: [0] tag=0: "a" [1] tag=0: "ks" [2] tag=0: "j" [3] tag=1: "nd" [4] tag=0: "kaj" [5] tag=0: "nd" ```)) (end-suite) janet-1.41.2/test/suite-pp.janet000066400000000000000000000044421514534607600164670ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose & contributors # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Appending buffer to self # 6b76ac3d1 (with-dyns [:out @""] (prin "abcd") (prin (dyn :out)) (prin (dyn :out)) (assert (deep= (dyn :out) @"abcdabcdabcdabcd") "print buffer to self")) # Buffer self blitting, check for use after free # bbcfaf128 (def buf1 @"1234567890") (buffer/blit buf1 buf1 -1) (buffer/blit buf1 buf1 -1) (buffer/blit buf1 buf1 -1) (buffer/blit buf1 buf1 -1) (assert (= (string buf1) (string/repeat "1234567890" 16)) "buffer blit against self") # Check for bugs with printing self with buffer/format # bbcfaf128 (def buftemp @"abcd") (assert (= (string (buffer/format buftemp "---%p---" buftemp)) `abcd---@"abcd"---`) "buffer/format on self 1") (def buftemp @"abcd") (assert (= (string (buffer/format buftemp "---%p %p---" buftemp buftemp)) `abcd---@"abcd" @"abcd"---`) "buffer/format on self 2") # 5c364e0 (defn check-jdn [x] (assert (deep= (parse (string/format "%j" x)) x) "round trip jdn")) (check-jdn 0) (check-jdn nil) (check-jdn []) (check-jdn @[[] [] 1231 9.123123 -123123 0.1231231230001]) (check-jdn -0.123123123123) (check-jdn 12837192371923) (check-jdn "a string") (check-jdn @"a buffer") (end-suite) janet-1.41.2/test/suite-specials.janet000066400000000000000000000142771514534607600176620ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Disable linting warnings (setdyn *lint-warn* :none) # Regression Test #137 # affcb5b45 (def [a b c] (range 10)) (assert (= a 0) "regression #137 (1)") (assert (= b 1) "regression #137 (2)") (assert (= c 2) "regression #137 (3)") (var [x y z] (range 10)) (assert (= x 0) "regression #137 (4)") (assert (= y 1) "regression #137 (5)") (assert (= z 2) "regression #137 (6)") # Test destructuring # 23dcfb986 (do (def test-tab @{:a 1 :b 2}) (def {:a a :b b} test-tab) (assert (= a 1) "dictionary destructuring 1") (assert (= b 2) "dictionary destructuring 2")) (do (def test-tab @{'a 1 'b 2 3 4}) (def {'a a 'b b (+ 1 2) c} test-tab) (assert (= a 1) "dictionary destructuring 3") (assert (= b 2) "dictionary destructuring 4") (assert (= c 4) "dictionary destructuring 5 - expression as key")) # cb5af974a (let [test-tuple [:a :b 1 2]] (def [a b one two] test-tuple) (assert (= a :a) "tuple destructuring 1") (assert (= b :b) "tuple destructuring 2") (assert (= two 2) "tuple destructuring 3")) (let [test-tuple [:a :b 1 2]] (def [a & rest] test-tuple) (assert (= a :a) "tuple destructuring 4 - rest") (assert (= rest [:b 1 2]) "tuple destructuring 5 - rest")) (do (def [a b & rest] [:a :b nil :d]) (assert (= a :a) "tuple destructuring 6 - rest") (assert (= b :b) "tuple destructuring 7 - rest") (assert (= rest [nil :d]) "tuple destructuring 8 - rest")) # 71cffc973 (do (def [[a b] x & rest] [[1 2] :a :c :b :a]) (assert (= a 1) "tuple destructuring 9 - rest") (assert (= b 2) "tuple destructuring 10 - rest") (assert (= x :a) "tuple destructuring 11 - rest") (assert (= rest [:c :b :a]) "tuple destructuring 12 - rest")) # 651e12cfe (do (def [a b & rest] [:a :b]) (assert (= a :a) "tuple destructuring 13 - rest") (assert (= b :b) "tuple destructuring 14 - rest") (assert (= rest []) "tuple destructuring 15 - rest")) (do (def [[a b & r1] c & r2] [[:a :b 1 2] :c 3 4]) (assert (= a :a) "tuple destructuring 16 - rest") (assert (= b :b) "tuple destructuring 17 - rest") (assert (= c :c) "tuple destructuring 18 - rest") (assert (= r1 [1 2]) "tuple destructuring 19 - rest") (assert (= r2 [3 4]) "tuple destructuring 20 - rest")) # Metadata # ec2d7bf34 (def foo-with-tags :a-tag :bar) (assert (get (dyn 'foo-with-tags) :a-tag) "extra keywords in def are metadata tags") (def foo-with-meta {:baz :quux} :bar) (assert (= :quux (get (dyn 'foo-with-meta) :baz)) "extra struct in def is metadata") (defn foo-fn-with-meta {:baz :quux} "This is a function" [x] (identity x)) (assert (= :quux (get (dyn 'foo-fn-with-meta) :baz)) "extra struct in defn is metadata") (assert (= "(foo-fn-with-meta x)\n\nThis is a function" (get (dyn 'foo-fn-with-meta) :doc)) "extra string in defn is docstring") # Break # 4a111b38b (var summation 0) (for i 0 10 (+= summation i) (if (= i 7) (break))) (assert (= summation 28) "break 1") (assert (= nil ((fn [] (break) 4))) "break 2") # Break with value # 8ba112116 # Shouldn't error out (assert-no-error "break 3" (for i 0 10 (if (> i 8) (break i)))) (assert-no-error "break 4" ((fn [i] (if (> i 8) (break i))) 100)) # No useless splices # 7d57f8700 (check-compile-error '((splice [1 2 3]) 0)) (check-compile-error '(if ;[1 2] 5)) (check-compile-error '(while ;[1 2 3] (print :hi))) (check-compile-error '(def x ;[1 2 3])) (check-compile-error '(fn [x] ;[x 1 2 3])) # No splice propagation (check-compile-error '(+ 1 (do ;[2 3 4]) 5)) (check-compile-error '(+ 1 (upscope ;[2 3 4]) 5)) # compiler inlines when condition is constant, ensure that optimization # doesn't break (check-compile-error '(+ 1 (if true ;[3 4]))) (check-compile-error '(+ 1 (if false nil ;[3 4]))) # Keyword arguments # 3f137ed0b (defn myfn [x y z &keys {:a a :b b :c c}] (+ x y z a b c)) (assert (= (+ ;(range 6)) (myfn 0 1 2 :a 3 :b 4 :c 5)) "keyword args 1") (assert (= (+ ;(range 6)) (myfn 0 1 2 :a 1 :b 6 :c 5 :d 11)) "keyword args 2") # Named arguments # 87fc339 (defn named-arguments [&named bob sally joe] (+ bob sally joe)) (assert (= 15 (named-arguments :bob 3 :sally 5 :joe 7)) "named arguments 1") # a117252 (defn named-opt-arguments [&opt x &named a b c] (+ x a b c)) (assert (= 10 (named-opt-arguments 1 :a 2 :b 3 :c 4)) "named arguments 2") # # fn compilation special # # b8032ec61 (defn myfn1 [[x y z] & more] more) (defn myfn2 [head & more] more) (assert (= (myfn1 [1 2 3] 4 5 6) (myfn2 [:a :b :c] 4 5 6)) "destructuring and varargs") # Nested quasiquotation # 4199c42fe (def nested ~(a ~(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) (assert (deep= nested '(a ~(b ,(+ 1 2) ,(foo 4 d) e) f)) "nested quasiquote") # Regression #400 # 7a84fc474 (assert (= nil (while (and false false) (fn []) (error "should not happen"))) "strangeloop 1") (assert (= nil (while (not= nil nil) (fn []) (error "should not happen"))) "strangeloop 2") # 919 # a097537a0 (defn test [] (var x 1) (set x ~(,x ())) x) (assert (= (test) '(1 ())) "issue #919") # Regression #1327 (def x "A") (def x (if (= nil x) "B" x)) (assert (= x "A")) (end-suite) janet-1.41.2/test/suite-string.janet000066400000000000000000000151011514534607600173500ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # 8a346ec (assert (= (string/join @["one" "two" "three"]) "onetwothree") "string/join 1 argument") (assert (= (string/join @["one" "two" "three"] ", ") "one, two, three") "string/join 2 arguments") (assert (= (string/join @[] ", ") "") "string/join empty array") (assert (= (string/find "123" "abc123def") 3) "string/find positive") (assert (= (string/find "1234" "abc123def") nil) "string/find negative") # String functions # f41dab8f6 (assert (= 3 (string/find "abc" " abcdefghijklmnop")) "string/find 1") (assert (= 0 (string/find "A" "A")) "string/find 2") (assert (string/has-prefix? "" "foo") "string/has-prefix? 1") (assert (string/has-prefix? "fo" "foo") "string/has-prefix? 2") (assert (not (string/has-prefix? "o" "foo")) "string/has-prefix? 3") (assert (string/has-suffix? "" "foo") "string/has-suffix? 1") (assert (string/has-suffix? "oo" "foo") "string/has-suffix? 2") (assert (not (string/has-suffix? "f" "foo")) "string/has-suffix? 3") (assert (= (string/replace "X" "." "XXX...XXX...XXX") ".XX...XXX...XXX") "string/replace 1") (assert (= (string/replace-all "X" "." "XXX...XXX...XXX") "...............") "string/replace-all 1") (assert (= (string/replace-all "XX" "." "XXX...XXX...XXX") ".X....X....X") "string/replace-all 2") (assert (= (string/replace "xx" string/ascii-upper "xxyxyxyxxxy") "XXyxyxyxxxy") "string/replace function") (assert (= (string/replace-all "xx" string/ascii-upper "xxyxyxyxxxy") "XXyxyxyXXxy") "string/replace-all function") (assert (= (string/replace "x" 12 "xyx") "12yx") "string/replace stringable") (assert (= (string/replace-all "x" 12 "xyx") "12y12") "string/replace-all stringable") (assert (= (string/ascii-lower "ABCabc&^%!@:;.") "abcabc&^%!@:;.") "string/ascii-lower") (assert (= (string/ascii-upper "ABCabc&^%!@:;.") "ABCABC&^%!@:;.") "string/ascii-lower") (assert (= (string/reverse "") "") "string/reverse 1") (assert (= (string/reverse "a") "a") "string/reverse 2") (assert (= (string/reverse "abc") "cba") "string/reverse 3") (assert (= (string/reverse "abcd") "dcba") "string/reverse 4") (assert (= (string/join @["one" "two" "three"] ",") "one,two,three") "string/join 1") (assert (= (string/join @["one" "two" "three"] ", ") "one, two, three") "string/join 2") (assert (= (string/join @["one" "two" "three"]) "onetwothree") "string/join 3") (assert (= (string/join @[] "hi") "") "string/join 4") (assert (= (string/trim " abcd ") "abcd") "string/trim 1") (assert (= (string/trim "abcd \t\t\r\f") "abcd") "string/trim 2") (assert (= (string/trim "\n\n\t abcd") "abcd") "string/trim 3") (assert (= (string/trim "") "") "string/trim 4") (assert (= (string/triml " abcd ") "abcd ") "string/triml 1") (assert (= (string/triml "\tabcd \t\t\r\f") "abcd \t\t\r\f") "string/triml 2") (assert (= (string/triml "abcd ") "abcd ") "string/triml 3") (assert (= (string/trimr " abcd ") " abcd") "string/trimr 1") (assert (= (string/trimr "\tabcd \t\t\r\f") "\tabcd") "string/trimr 2") (assert (= (string/trimr " abcd") " abcd") "string/trimr 3") (assert (deep= (string/split "," "one,two,three") @["one" "two" "three"]) "string/split 1") (assert (deep= (string/split "," "onetwothree") @["onetwothree"]) "string/split 2") (assert (deep= (string/find-all "e" "onetwothree") @[2 9 10]) "string/find-all 1") (assert (deep= (string/find-all "," "onetwothree") @[]) "string/find-all 2") # b26a7bb22 (assert-error "string/find error 1" (string/find "" "abcd")) (assert-error "string/split error 1" (string/split "" "abcd")) (assert-error "string/replace error 1" (string/replace "" "." "abcd")) (assert-error "string/replace-all error 1" (string/replace-all "" "." "abcdabcd")) (assert-error "string/find-all error 1" (string/find-all "" "abcd")) # String bugs # bcba0c027 (assert (deep= (string/find-all "qq" "qqq") @[0 1]) "string/find-all 1") (assert (deep= (string/find-all "q" "qqq") @[0 1 2]) "string/find-all 2") (assert (deep= (string/split "qq" "1qqqqz") @["1" "" "z"]) "string/split 1") (assert (deep= (string/split "aa" "aaa") @["" "a"]) "string/split 2") # some tests for string/format # 0f0c415 (assert (= (string/format "pi = %6.3f" math/pi) "pi = 3.142") "%6.3f") (assert (= (string/format "pi = %+6.3f" math/pi) "pi = +3.142") "%6.3f") (assert (= (string/format "pi = %40.20g" math/pi) "pi = 3.141592653589793116") "%6.3f") (assert (= (string/format "🐼 = %6.3f" math/pi) "🐼 = 3.142") "UTF-8") (assert (= (string/format "π = %.8g" math/pi) "π = 3.1415927") "π") (assert (= (string/format "\xCF\x80 = %.8g" math/pi) "\xCF\x80 = 3.1415927") "\xCF\x80") # String check-set # b4e25e559 (assert (string/check-set "abc" "a") "string/check-set 1") (assert (not (string/check-set "abc" "z")) "string/check-set 2") (assert (string/check-set "abc" "abc") "string/check-set 3") (assert (string/check-set "abc" "") "string/check-set 4") (assert (not (string/check-set "" "aabc")) "string/check-set 5") (assert (not (string/check-set "abc" "abcdefg")) "string/check-set 6") # Trim empty string # issue #174 - 9b605b27b (assert (= "" (string/trim " ")) "string/trim regression") # Keyword and Symbol slice # e9911fee4 (assert (= :keyword (keyword/slice "some_keyword_slice" 5 12)) "keyword slice") (assert (= 'symbol (symbol/slice "some_symbol_slice" 5 11)) "symbol slice") # Check string formatting, #1600 (assert (= "" (string/format "%.99s" @"")) "string/format %s buffer") (end-suite) janet-1.41.2/test/suite-strtod.janet000066400000000000000000000027061514534607600173700ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Scan number # 798c88b4c (assert (= 1 (scan-number "1")) "scan-number 1") (assert (= -1 (scan-number "-1")) "scan-number -1") (assert (= 1.3e4 (scan-number "1.3e4")) "scan-number 1.3e4") # Issue #183 - just parse it :) # 688d297a1 1e-4000000000000000000000 # For undefined behavior sanitizer # c876e63 0xf&1fffFFFF (end-suite) janet-1.41.2/test/suite-struct.janet000066400000000000000000000072001514534607600173670ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # 21bd960 (assert (= (struct 1 2 3 4 5 6 7 8) (struct 7 8 5 6 3 4 1 2)) "struct order does not matter 1") # 42a88de (assert (= (struct :apple 1 6 :bork '(1 2 3) 5) (struct 6 :bork '(1 2 3) 5 :apple 1)) "struct order does not matter 2") # Denormal structs # 38a7e4faf (assert (= (length {1 2 nil 3}) 1) "nil key struct literal") (assert (= (length (struct 1 2 nil 3)) 1) "nil key struct ctor") (assert (= (length (struct (/ 0 0) 2 1 3)) 1) "nan key struct ctor") (assert (= (length {1 2 (/ 0 0) 3}) 1) "nan key struct literal") (assert (= (length (struct 2 1 3 nil)) 1) "nil value struct ctor") (assert (= (length {1 2 3 nil}) 1) "nil value struct literal") # Struct duplicate elements # 8bc2987a7 (assert (= {:a 3 :b 2} {:a 1 :b 2 :a 3}) "struct literal duplicate keys") (assert (= {:a 3 :b 2} (struct :a 1 :b 2 :a 3)) "struct constructor duplicate keys") # Struct prototypes # 4d983e5 (def x (struct/with-proto {1 2 3 4} 5 6)) (def y (-> x marshal unmarshal)) (def z {1 2 3 4}) (assert (= 2 (get x 1)) "struct get proto value 1") (assert (= 4 (get x 3)) "struct get proto value 2") (assert (= 6 (get x 5)) "struct get proto value 3") (assert (= x y) "struct proto marshal equality 1") (assert (= (getproto x) (getproto y)) "struct proto marshal equality 2") (assert (= 0 (cmp x y)) "struct proto comparison 1") (assert (= 0 (cmp (getproto x) (getproto y))) "struct proto comparison 2") (assert (not= (cmp x z) 0) "struct proto comparison 3") (assert (not= (cmp y z) 0) "struct proto comparison 4") (assert (not= x z) "struct proto comparison 5") (assert (not= y z) "struct proto comparison 6") (assert (= (x 5) 6) "struct proto get 1") (assert (= (y 5) 6) "struct proto get 1") (assert (deep= x y) "struct proto deep= 1") (assert (deep-not= x z) "struct proto deep= 2") (assert (deep-not= y z) "struct proto deep= 3") # Check missing struct proto bug # 868ec1a7e, e08394c8 (assert (struct/getproto (struct/with-proto {:a 1} :b 2 :c nil)) "missing struct proto") # struct/with-proto (assert-error "expected odd number of arguments" (struct/with-proto {} :a)) # struct/to-table (def s (struct/with-proto {:a 1 :b 2} :name "john" )) (def t1 (struct/to-table s true)) (def t2 (struct/to-table s false)) (assert (deep= t1 @{:name "john"}) "struct/to-table 1") (assert (deep= t2 @{:name "john"}) "struct/to-table 2") (assert (deep= (getproto t1) @{:a 1 :b 2}) "struct/to-table 3") (assert (deep= (getproto t2) nil) "struct/to-table 4") (end-suite) janet-1.41.2/test/suite-symcache.janet000066400000000000000000000031231514534607600176370ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Symbol function # 5460ff1 (assert (= (symbol "abc" 1 2 3) 'abc123) "symbol function") # Gensym tests # 3ccd68843 (assert (not= (gensym) (gensym)) "two gensyms not equal") ((fn [] (def syms (table)) (var counter 0) (while (< counter 128) (put syms (gensym) true) (set counter (+ 1 counter))) (assert (= (length syms) 128) "many symbols"))) # issue #753 - a78cbd91d (assert (pos? (length (gensym))) "gensym not empty, regression #753") (end-suite) janet-1.41.2/test/suite-table.janet000066400000000000000000000047071514534607600171430ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Denormal tables # 38a7e4faf (assert (= (length @{1 2 nil 3}) 1) "nil key table literal") (assert (= (length (table 1 2 nil 3)) 1) "nil key table ctor") (assert (= (length (table (/ 0 0) 2 1 3)) 1) "nan key table ctor") (assert (= (length @{1 2 (/ 0 0) 3}) 1) "nan key table literal") (assert (= (length (table 2 1 3 nil)) 1) "nil value table ctor") (assert (= (length @{1 2 3 nil}) 1) "nil value table literal") # Table duplicate elements (assert (deep= @{:a 3 :b 2} @{:a 1 :b 2 :a 3}) "table literal duplicate keys") (assert (deep= @{:a 3 :b 2} (table :a 1 :b 2 :a 3)) "table constructor duplicate keys") ## Table prototypes # 027b2a81c (def roottab @{ :parentprop 123 }) (def childtab @{ :childprop 456 }) (table/setproto childtab roottab) (assert (= 123 (get roottab :parentprop)) "table get 1") (assert (= 123 (get childtab :parentprop)) "table get proto") (assert (= nil (get roottab :childprop)) "table get 2") (assert (= 456 (get childtab :childprop)) "proto no effect") # b3aed1356 (assert-error "table rawget regression" (table/new -1)) # table/clone # 392813667 (defn check-table-clone [x msg] (assert (= (table/to-struct x) (table/to-struct (table/clone x))) msg)) (check-table-clone @{:a 123 :b 34 :c :hello : 945 0 1 2 3 4 5} "table/clone 1") (check-table-clone @{} "table/clone 2") (end-suite) janet-1.41.2/test/suite-tuple.janet000066400000000000000000000026071514534607600172020ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) (assert (= [1 2 3] (tuple/join [1] [2] [3])) "tuple/join 1") (assert (= [] (tuple/join)) "tuple/join 2") (assert (= [:a :b :c] (tuple/join @[:a :b] [] [:c])) "tuple/join 3") (assert (= ["abc123" "def456"] (tuple/join ["abc123" "def456"])) "tuple/join 4") (end-suite) janet-1.41.2/test/suite-unknown.janet000066400000000000000000000216231514534607600175470ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # Disable linting warnings (setdyn *lint-warn* :none) # Set global variables to prevent some possible compiler optimizations # that defeat point of the test # 2771171 (var zero 0) (var one 1) (var two 2) (var three 3) (var plus +) (assert (= 22 (plus one (plus 1 2 two) (plus 8 (plus zero 1) 4 three))) "nested function calls") # McCarthy's 91 function # 2771171 (var f91 nil) (set f91 (fn [n] (if (> n 100) (- n 10) (f91 (f91 (+ n 11)))))) (assert (= 91 (f91 10)) "f91(10) = 91") (assert (= 91 (f91 11)) "f91(11) = 91") (assert (= 91 (f91 20)) "f91(20) = 91") (assert (= 91 (f91 31)) "f91(31) = 91") (assert (= 91 (f91 100)) "f91(100) = 91") (assert (= 91 (f91 101)) "f91(101) = 91") (assert (= 92 (f91 102)) "f91(102) = 92") (assert (= 93 (f91 103)) "f91(103) = 93") (assert (= 94 (f91 104)) "f91(104) = 94") # Fibonacci # 23196ff (def fib (do (var fib nil) (set fib (fn [n] (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))))) (def fib2 (fn fib2 [n] (if (< n 2) n (+ (fib2 (- n 1)) (fib2 (- n 2)))))) (assert (= (fib 0) (fib2 0) 0) "fib(0)") (assert (= (fib 1) (fib2 1) 1) "fib(1)") (assert (= (fib 2) (fib2 2) 1) "fib(2)") (assert (= (fib 3) (fib2 3) 2) "fib(3)") (assert (= (fib 4) (fib2 4) 3) "fib(4)") (assert (= (fib 5) (fib2 5) 5) "fib(5)") (assert (= (fib 6) (fib2 6) 8) "fib(6)") (assert (= (fib 7) (fib2 7) 13) "fib(7)") (assert (= (fib 8) (fib2 8) 21) "fib(8)") (assert (= (fib 9) (fib2 9) 34) "fib(9)") (assert (= (fib 10) (fib2 10) 55) "fib(10)") # Closure in non function scope # 911b0b1 (def outerfun (fn [x y] (def c (do (def someval (+ 10 y)) (def ctemp (if x (fn [] someval) (fn [] y))) ctemp )) (+ 1 2 3 4 5 6 7) c)) (assert (= ((outerfun 1 2)) 12) "inner closure 1") (assert (= ((outerfun nil 2)) 2) "inner closure 2") (assert (= ((outerfun false 3)) 3) "inner closure 3") # d6967a5 ((fn [] (var accum 1) (var counter 0) (while (< counter 16) (set accum (blshift accum 1)) (set counter (+ 1 counter))) (assert (= accum 65536) "loop in closure"))) (var accum 1) (var counter 0) (while (< counter 16) (set accum (blshift accum 1)) (set counter (+ 1 counter))) (assert (= accum 65536) "loop globally") # Fiber tests # 21bd960 (def afiber (fiber/new (fn [] (def x (yield)) (error (string "hello, " x))) :ye)) (resume afiber) # first resume to prime (def afiber-result (resume afiber "world!")) (assert (= afiber-result "hello, world!") "fiber error result") (assert (= (fiber/status afiber) :error) "fiber error status") # Var arg tests # f054586 (def vargf (fn [more] (apply + more))) (assert (= 0 (vargf @[])) "var arg no arguments") (assert (= 1 (vargf @[1])) "var arg no packed arguments") (assert (= 3 (vargf @[1 2])) "var arg tuple size 1") (assert (= 10 (vargf @[1 2 3 4])) "var arg tuple size 2, 2 normal args") (assert (= 110 (vargf @[1 2 3 4 10 10 10 10 10 10 10 10 10 10])) "var arg large tuple") # Higher order functions # d9f24ef (def compose (fn [f g] (fn [& xs] (f (apply g xs))))) (def -+ (compose - +)) (def +- (compose + -)) (assert (= (-+ 1 2 3 4) -10) "compose - +") (assert (= (+- 1 2 3 4) -8) "compose + -") (assert (= ((compose -+ +-) 1 2 3 4) 8) "compose -+ +-") (assert (= ((compose +- -+) 1 2 3 4) 10) "compose +- -+") # UTF-8 # d9f24ef #🐙🐙🐙🐙 (defn foo [Θa Θb Θc] 0) (def 🦊 :fox) (def 🐮 :cow) (assert (= (string "🐼" 🦊 🐮) "🐼foxcow") "emojis 🙉 :)") (assert (not= 🦊 "🦊") "utf8 strings are not symbols and vice versa") (assert (= "\U01F637" "😷") "unicode escape 1") (assert (= "\u2623" "\U002623" "☣") "unicode escape 2") (assert (= "\u24c2" "\U0024c2" "Ⓜ") "unicode escape 3") (assert (= "\u0061" "a") "unicode escape 4") # Test max triangle program # c0e373f # Find the maximum path from the top (root) # of the triangle to the leaves of the triangle. (defn myfold [xs ys] (let [xs1 [;xs 0] xs2 [0 ;xs] m1 (map + xs1 ys) m2 (map + xs2 ys)] (map max m1 m2))) (defn maxpath [t] (extreme > (reduce myfold () t))) # Test it # Maximum path is 3 -> 10 -> 3 -> 9 for a total of 25 (def triangle '[ [3] [7 10] [4 3 7] [8 9 1 3] ]) (assert (= (maxpath triangle) 25) `max triangle`) # Large functions # 6822400 (def manydefs (seq [i :range [0 300]] (tuple 'def (gensym) (string "value_" i)))) (array/push manydefs (tuple * 10000 3 5 7 9)) (def f (compile ['do ;manydefs] (fiber/getenv (fiber/current)))) (assert (= (f) (* 10000 3 5 7 9)) "long function compilation") # Closure in while loop # abe7d59 (def closures (seq [i :range [0 5]] (fn [] i))) (assert (= 0 ((get closures 0))) "closure in loop 0") (assert (= 1 ((get closures 1))) "closure in loop 1") (assert (= 2 ((get closures 2))) "closure in loop 2") (assert (= 3 ((get closures 3))) "closure in loop 3") (assert (= 4 ((get closures 4))) "closure in loop 4") # Another regression test - no segfaults # 6b4824c (defn afn [x] x) (var afn-var afn) (var identity-var identity) (var map-var map) (var not-var not) (assert (= 1 (try (afn-var) ([err] 1))) "bad arity 1") (assert (= 4 (try ((fn [x y] (+ x y)) 1) ([_] 4))) "bad arity 2") (assert (= 1 (try (identity-var) ([err] 1))) "bad arity 3") (assert (= 1 (try (map-var) ([err] 1))) "bad arity 4") (assert (= 1 (try (not-var) ([err] 1))) "bad arity 5") # Detaching closure over non resumable fiber # issue #317 - 7c4ffe9b9 (do (defn f1 [a] (defn f1 [] (++ (a 0))) (defn f2 [] (++ (a 0))) (error [f1 f2])) (def [_ [f1 f2]] (protect (f1 @[0]))) # At time of writing, mark phase can detach closure envs. (gccollect) (assert (= 1 (f1)) "detach-non-resumable-closure 1") (assert (= 2 (f2)) "detach-non-resumable-closure 2")) # Dynamic defs # ec65f03 (def staticdef1 0) (defn staticdef1-inc [] (+ 1 staticdef1)) (assert (= 1 (staticdef1-inc)) "before redefinition without :redef") (def staticdef1 1) (assert (= 1 (staticdef1-inc)) "after redefinition without :redef") (setdyn :redef true) (def dynamicdef2 0) (defn dynamicdef2-inc [] (+ 1 dynamicdef2)) (assert (= 1 (dynamicdef2-inc)) "before redefinition with dyn :redef") (def dynamicdef2 1) (assert (= 2 (dynamicdef2-inc)) "after redefinition with dyn :redef") (setdyn :redef nil) # missing symbols # issue #914 - 1eb34989d (defn lookup-symbol [sym] (defglobal sym 10) (dyn sym)) (setdyn :missing-symbol lookup-symbol) (assert (= (eval-string "(+ a 5)") 15) "lookup missing symbol") (setdyn :missing-symbol nil) (setdyn 'a nil) (assert-error "compile error" (eval-string "(+ a 5)")) # 88813c4 (assert (deep= (in (disasm (defn a [] (def x 10) x)) :symbolmap) @[[0 2 0 'a] [0 2 1 'x]]) "symbolmap when *debug* is true") (defn a [arg] (def x 10) (do (def y 20) (def z 30) (+ x y z))) (def symbolslots (in (disasm a) :symbolslots)) (def f (asm (disasm a))) (assert (deep= (in (disasm f) :symbolslots) symbolslots) "symbolslots survive disasm/asm") (comment (setdyn *debug* true) (setdyn :pretty-format "%.40M") (def f (fn [x] (fn [y] (+ x y)))) (assert (deep= (map last (in (disasm (f 10)) :symbolmap)) @['x 'y]) "symbolmap upvalues")) (assert (deep= (in (disasm (defn a [arg] (def x 10) (do (def y 20) (def z 30) (+ x y z)))) :symbolmap) @[[0 6 0 'arg] [0 6 1 'a] [0 6 2 'x] [1 6 3 'y] [2 6 4 'z]]) "arg & inner symbolmap") # 4782a76 (assert (= 10 (do (var x 10) (def y x) (++ x) y)) "no invalid aliasing") (end-suite) janet-1.41.2/test/suite-value.janet000066400000000000000000000051621514534607600171640ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # 3e1e25854 (def test-struct {'def 1 'bork 2 'sam 3 'a 'b 'het @[1 2 3 4 5]}) (assert (= (get test-struct 'def) 1) "struct get") (assert (= (get test-struct 'bork) 2) "struct get") (assert (= (get test-struct 'sam) 3) "struct get") (assert (= (get test-struct 'a) 'b) "struct get") (assert (= :array (type (get test-struct 'het))) "struct get") # Buffer stuff # 910cfd7dd (defn buffer= [a b] (= (string a) (string b))) (assert (buffer= @"abcd" @"abcd") "buffer equal 1") (assert (buffer= @"abcd" (buffer "ab" "cd")) "buffer equal 2") (assert (not= @"" @"") "buffer not equal 1") (assert (not= @"abcd" @"abcd") "buffer not equal 2") (defn buffer-factory [] @"i am a buffer") (assert (not= (buffer-factory) (buffer-factory)) "buffer instantiation") (assert (= (length @"abcdef") 6) "buffer length") # Tuple comparison # da438a93e (assert (< [1 2 3] [2 2 3]) "tuple comparison 1") (assert (< [1 2 3] [2 2]) "tuple comparison 2") (assert (< [1 2 3] [2 2 3 4]) "tuple comparison 3") (assert (< [1 2 3] [1 2 3 4]) "tuple comparison 4") (assert (< [1 2 3] [1 2 3 -1]) "tuple comparison 5") (assert (> [1 2 3] [1 2]) "tuple comparison 6") # More numerical tests # e05022f (assert (= 1 1.0) "numerical equal 1") (assert (= 0 0.0) "numerical equal 2") (assert (= 0 -0.0) "numerical equal 3") (assert (= 2_147_483_647 2_147_483_647.0) "numerical equal 4") (assert (= -2_147_483_648 -2_147_483_648.0) "numerical equal 5") # issue #928 - d7ea122cf (assert (= (hash 0) (hash (* -1 0))) "hash -0 same as hash 0") (end-suite) janet-1.41.2/test/suite-vm.janet000066400000000000000000000107341514534607600164730ustar00rootroot00000000000000# Copyright (c) 2026 Calvin Rose # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS # IN THE SOFTWARE. (import ./helper :prefix "" :exit true) (start-suite) # More fiber semantics # 0fd9224e4 (var myvar 0) (defn fiberstuff [&] (++ myvar) (def f (fiber/new (fn [&] (++ myvar) (debug) (++ myvar)))) (resume f) (++ myvar)) (def myfiber (fiber/new fiberstuff :dey)) (assert (= myvar 0) "fiber creation does not call fiber function") (resume myfiber) (assert (= myvar 2) "fiber debug statement breaks at proper point") (assert (= (fiber/status myfiber) :debug) "fiber enters debug state") (resume myfiber) (assert (= myvar 4) "fiber resumes properly from debug state") (assert (= (fiber/status myfiber) :dead) "fiber properly dies from debug state") # yield tests # 171c0ce (def t (fiber/new (fn [&] (yield 1) (yield 2) 3))) (assert (= 1 (resume t)) "initial transfer to new fiber") (assert (= 2 (resume t)) "second transfer to fiber") (assert (= 3 (resume t)) "return from fiber") (assert (= (fiber/status t) :dead) "finished fiber is dead") # Fix yields inside nested fibers # 909c906 (def yielder (coro (defer (yield :end) (repeat 5 (yield :item))))) (def items (seq [x :in yielder] x)) (assert (deep= @[:item :item :item :item :item :end] items) "yield within nested fibers") # Calling non functions # b9c0fc820 (assert (= 1 ({:ok 1} :ok)) "calling struct") (assert (= 2 (@{:ok 2} :ok)) "calling table") (assert (= :bad (try ((identity @{:ok 2}) :ok :no) ([_err] :bad))) "calling table too many arguments") (assert (= :bad (try ((identity :ok) @{:ok 2} :no) ([_err] :bad))) "calling keyword too many arguments") (assert (= :oops (try ((+ 2 -1) 1) ([_err] :oops))) "calling number fails") # Method test # d5bab7262 (def Dog @{:bark (fn bark [self what] (string (self :name) " says " what "!"))}) (defn make-dog [name] (table/setproto @{:name name} Dog)) (assert (= "fido" ((make-dog "fido") :name)) "oo 1") (def spot (make-dog "spot")) (assert (= "spot says hi!" (:bark spot "hi")) "oo 2") # Negative tests # 67f26b7d7 (assert-error "+ check types" (+ 1 ())) (assert-error "- check types" (- 1 ())) (assert-error "* check types" (* 1 ())) (assert-error "/ check types" (/ 1 ())) (assert-error "band check types" (band 1 ())) (assert-error "bor check types" (bor 1 ())) (assert-error "bxor check types" (bxor 1 ())) (assert-error "bnot check types" (bnot ())) # Comparisons # 10dcbc639 (assert (> 1e23 100) "less than immediate 1") (assert (> 1e23 1000) "less than immediate 2") (assert (< 100 1e23) "greater than immediate 1") (assert (< 1000 1e23) "greater than immediate 2") # Quasiquote bracketed tuples # e239980da (assert (= (tuple/type ~[1 2 3]) (tuple/type '[1 2 3])) "quasiquote bracket tuples") # Regression #638 # c68264802 (compwhen (dyn 'ev/go) (assert (= [true :caught] (protect (try (do (ev/sleep 0) (with-dyns [] (ev/sleep 0) (error "oops"))) ([_err] :caught)))) "regression #638")) # # Test propagation of signals via fibers # # b8032ec61 (def f (fiber/new (fn [] (error :abc) 1) :ei)) (def res (resume f)) (assert-error :abc (propagate res f) "propagate 1") # Cancel test # 28439d822 (def f (fiber/new (fn [&] (yield 1) (yield 2) (yield 3) 4) :yti)) (assert (= 1 (resume f)) "cancel resume 1") (assert (= 2 (resume f)) "cancel resume 2") (assert (= :hi (cancel f :hi)) "cancel resume 3") (assert (= :error (fiber/status f)) "cancel resume 4") (end-suite) janet-1.41.2/tools/000077500000000000000000000000001514534607600140535ustar00rootroot00000000000000janet-1.41.2/tools/.keep000066400000000000000000000000001514534607600147660ustar00rootroot00000000000000janet-1.41.2/tools/afl/000077500000000000000000000000001514534607600146155ustar00rootroot00000000000000janet-1.41.2/tools/afl/README.md000066400000000000000000000015271514534607600161010ustar00rootroot00000000000000# AFL Fuzzing scripts To use these, you need to install afl (of course), and xterm. A tiling window manager helps manage many concurrent fuzzer instances. Note, afl sometimes requires system configuration, if you find AFL quitting prematurely, try manually launching it and addressing any error messages. ## Fuzz the parser ``` $ sh ./tools/afl/prepare_to_fuzz.sh $ export NFUZZ=1 $ sh ./tools/afl/fuzz.sh parser Ctrl+C when done to close all fuzzer terminals. $ sh ./tools/afl/aggregate_cases.sh parser $ ls ./fuzz_out/parser_aggregated/ ``` ## Fuzz the unmarshaller ``` $ janet ./tools/afl/generate_unmarshal_testcases.janet $ sh ./tools/afl/prepare_to_fuzz.sh $ export NFUZZ=1 $ sh ./tools/afl/fuzz.sh unmarshal Ctrl+C when done to close all fuzzer terminals. $ sh ./tools/afl/aggregate_cases.sh unmarshal $ ls ./fuzz_out/unmarshal_aggregated/ ``` janet-1.41.2/tools/afl/aggregate_cases.sh000066400000000000000000000003721514534607600202570ustar00rootroot00000000000000set -eux n=0 for tc in $(echo ./fuzz_out/$1/*/hangs/* ./fuzz_out/$1/*/crashes/*) do if ! test -e $tc then continue fi mkdir -p ./fuzz_out/$1_aggregated/ cp "$tc" $(printf "./fuzz_out/$1_aggregated/$1-%04d.test" $n) n=$((n + 1)) done janet-1.41.2/tools/afl/fuzz.sh000066400000000000000000000013631514534607600161520ustar00rootroot00000000000000set -eux NFUZZ=${NFUZZ:-1} children="" function finish { for pid in $children do set +e kill -s INT $pid done wait } trap finish EXIT test -e ./tools/afl/$1_testcases test -e ./tools/afl/$1_runner.janet echo "running fuzz master..." xterm -e \ "afl-fuzz -i ./tools/afl/$1_testcases -o ./fuzz_out/$1 -M Fuzz$1_0 -- ./build/janet ./tools/afl/$1_runner.janet @@" & children="$! $children" echo "waiting for afl to get started before starting secondary fuzzers" sleep 10 NFUZZ=$((NFUZZ - 1)) for N in $(seq $NFUZZ) do xterm -e \ "afl-fuzz -i ./tools/afl/$1_testcases -o ./fuzz_out/$1 -S Fuzz$1_$N -- ./build/janet ./tools/afl/$1_runner.janet @@" & children="$! $children" done echo "waiting for child terminals to exit." wait janet-1.41.2/tools/afl/generate_unmarshal_testcases.janet000066400000000000000000000011331514534607600235600ustar00rootroot00000000000000 (os/mkdir "./tools/afl/unmarshal_testcases/") (defn spit-case [n v] (spit (string "./tools/afl/unmarshal_testcases/" (string n)) (marshal v make-image-dict))) (def cases [ nil "abc" :def 'hij 123 (int/s64 123) "7" [1 2 3] @[1 2 3] {:a 123} @{:b 'xyz} (peg/compile '{:a (* "a" :b "a") :b (* "b" (+ :a 0) "b") :main (* "(" :b ")")}) (fn f [a] (fn [] {:ab a})) (fn f [a] (print "hello world!")) (do (defn f [a] (yield) @[1 "2"]) (def fb (fiber/new f)) (resume fb) fb) ]) (eachk i cases (spit-case i (in cases i))) janet-1.41.2/tools/afl/parser_runner.janet000066400000000000000000000001661514534607600205300ustar00rootroot00000000000000(def p (parser/new)) (parser/consume p (slurp ((dyn :args) 1))) (while (parser/has-more p) (pp (parser/produce p))) janet-1.41.2/tools/afl/parser_testcases/000077500000000000000000000000001514534607600201675ustar00rootroot00000000000000janet-1.41.2/tools/afl/parser_testcases/simple.janet000066400000000000000000000001561514534607600225050ustar00rootroot000000000000000 123.653 true :true {} ` hello ` |() ,() @{:hello "world"} @[1 "hello"] nil (foo 2 3) ([{} @{:k ([""])}]) janet-1.41.2/tools/afl/prepare_to_fuzz.sh000066400000000000000000000001241514534607600203640ustar00rootroot00000000000000set -eux export CC=afl-clang make clean make -j $(nproc) all mkdir -p "./fuzz_out" janet-1.41.2/tools/afl/unmarshal_runner.janet000066400000000000000000000002761514534607600212300ustar00rootroot00000000000000# Unmarshal garbage. (def v (unmarshal (slurp ((dyn :args) 1)) load-image-dict)) # Trigger leaks or use after free. (gccollect) # Attempt to use generated value. (marshal v make-image-dict) janet-1.41.2/tools/amalg.janet000066400000000000000000000007241514534607600161620ustar00rootroot00000000000000# Creates an amalgamated janet.c # Head (print "/* Amalgamated build - DO NOT EDIT */") (print "/* Generated from janet version " janet/version "-" janet/build " */") (print "#define JANET_BUILD \"" janet/build "\"") (print ```#define JANET_AMALG```) (print ```#define _POSIX_C_SOURCE 200112L```) (print ```#include "janet.h"```) # Body (each path (tuple/slice (dyn :args) 1) (print "\n/* " path " */\n") (print (slurp path))) # maybe will help (:flush stdout) janet-1.41.2/tools/format.sh000066400000000000000000000005171514534607600157020ustar00rootroot00000000000000#!/usr/bin/env sh # Format all code with astyle STYLEOPTS="--style=attach --indent-switches --convert-tabs \ --align-pointer=name --pad-header --pad-oper --unpad-paren --indent-labels --formatted" astyle $STYLEOPTS */*.c astyle $STYLEOPTS */*/*.c astyle $STYLEOPTS */*/*.h rm -f */*.c.orig rm -f */*/*.c.orig rm -f */*/*.h.orig janet-1.41.2/tools/gendoc.janet000066400000000000000000000054451514534607600163450ustar00rootroot00000000000000# Generate documentation (def- prelude ``` Janet Language Documentation ```) (def- postlude ``` ```) (def- escapes {10 "
" 09 "    " 38 "&" 60 "<" 62 ">" 34 """ 39 "'" 47 "/"}) (defn- trim-lead "Trim leading newlines" [str] (var i 0) (while (= 10 (get str i)) (++ i)) (string/slice str i)) (defn- html-escape "Escape special characters for HTML encoding." [str] (def buf @"") (loop [byte :in str] (if-let [rep (get escapes byte)] (buffer/push-string buf rep) (buffer/push-byte buf byte))) buf) (def- months '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December")) (defn nice-date "Get the current date nicely formatted" [] (let [date (os/date) M (months (date :month)) D (+ (date :month-day) 1) Y (date :year) HH (date :hours) MM (date :minutes) SS (date :seconds)] (string/format "%s %d, %d at %.2d:%.2d:%.2d" M D Y HH MM SS))) (defn- make-title "Generate title" [] (string "

Janet Core API

" "

Version " janet/version "-" janet/build "

" "

Generated " (nice-date) "

" "
")) (defn- emit-item "Generate documentation for one entry." [key env-entry] (let [{:macro macro :value val :ref ref :source-map sm :doc docstring} env-entry html-key (html-escape key) binding-type (cond macro :macro ref (string :var " (" (type (get ref 0)) ")") (type val)) source-ref (if-let [[path start end] sm] (string "" path " (" start ":" end ")") "")] (string "

" html-key "

\n" "" binding-type "\n" "

" (trim-lead (html-escape docstring)) "

\n" source-ref))) # Generate parts and print them to stdout (def parts (seq [[k entry] :in (sort (pairs (table/getproto (fiber/getenv (fiber/current))))) :when (symbol? k) :when (and (get entry :doc) (not (get entry :private)))] (emit-item k entry))) (print prelude (make-title) ;(interpose "
\n" parts) postlude) janet-1.41.2/tools/hashbench/000077500000000000000000000000001514534607600157765ustar00rootroot00000000000000janet-1.41.2/tools/hashbench/ints1.janet000066400000000000000000000011751514534607600200630ustar00rootroot00000000000000(def f @{}) (var collisions 0) (loop [x :range [0 300] y :range [0 300]] (def key (hash (+ (* x 1000) y))) (if (in f key) (++ collisions)) (put f key true)) (print "ints 1 collisions: " collisions) (def f @{}) (var collisions 0) (loop [x :range [100000 101000] y :range [100000 101000]] (def key (hash [x y])) (if (in f key) (++ collisions)) (put f key true)) (print "int pair 1 collisions: " collisions) (def f @{}) (var collisions 0) (loop [x :range [10000 11000] y :range [10000 11000]] (def key (hash [x y])) (if (in f key) (++ collisions)) (put f key true)) (print "int pair 2 collisions: " collisions) janet-1.41.2/tools/msi/000077500000000000000000000000001514534607600146435ustar00rootroot00000000000000janet-1.41.2/tools/msi/JanetDialog.png000066400000000000000000000604361514534607600175430ustar00rootroot00000000000000PNG  IHDR8vGg IDATxwxU",Rl+Bz Į(* AH9K^ikdf2!F+@'af󞻋VoDbBh4SӇ6mVFjj֦j~h4ZMMڴY[MFSCZ6kAhj55}Hkfm5}?h4MimڬF!Mh4VmDb5}?h4MimڬF!][ŪM4_f;hbް4J͙ܾDW qwXHp?q~~t y4p{"?tMMh7"ϵj~h4ZMM5ilް4p۷ԋ ׄqIH@r͖pK $I_ _hm M^ZTEm4V ɚ=4ui R8 Q[]? ܹ9&ƞ|jj~h4ZMM.ҫ7s_>n8D t|VkY{ שw*wl?=ki?-FSCz^F}?"6Zq9}Y]S'WnqB"S-FS!]BmܜESt Np]D/Mg2Q#r)t|T04=  /)pws Ok}Fig-FSC<bq &^kqP?Onw^`e0Y!0YF>_UaEsƟaa7\,~Wx˝2xׂǾF!]9^:W\]G]?LN|{AkDZl zaf nP*ܞRpSN/4\A5[U#VFjjrv5CV":O*O:rW\"@H>B#CxVs,h[?'Z5C|f%7.(8x2]MMfE<@g{xN15hh4jizfEPoZVyf*sFyafg _vVp[B)oy'mNsʚδhk4MSӇ34x v%3XߝsT:8_2d{ضٿiIQT\wMFSCF|&G&P7gUht{1Xp+#!hS*5VvƟG-FSE;pwm8Hve.4[8<bm5L^y2dySȹǑyȩ9H7\d@.rq伓g瑡"yy3'毩6 g2/HiƟo-FSj~`zn/[qIK=ze$!u~]ASb뛍Fd#}sY o7韇~9rv.r]Huȉ_}t qw?D6>AN99}ch(~\1s29{ y7[~x)kZyucް^Fє>ʭ{Η0j2- r %ۋ|r"F =4"@NAW䐧}Dnd;nAzEzA"E9W{K܄wzz=C|I)8d#x[B~ ~1ʈfx MCa!U+ܗԺQGwGָXkh4'x`zn5[E vrm8rLr* U`[."O##_ۗ_KXJR!XQYdGAxAu w^`} {Z/F;R \845Z4Vs恛m)DQ?^-Xuى!)#WQuQ:9rh䀿"ۻ{fx( 6`}'΂M[vl,pcPY@/ABAbނ=ۺyvcȓ+WpyH: cq*Hr-FSkvq84~<5s;1,7\[/7Q_dN۰uvwW[WO)H7[PA`ONgi(<A |ou H駮j]gq[}{L]^M{hk4Mmfwmt_` MRlY"_gb*$֫X;(8г؞u8t-UUCK4]]F6n|=ƨv}.q#x{SE_Ee8d{쨎tOu[z9mrZvFwt+H+s3ܛXo~+6jh4+QlVvSypGԶ*=l`_iD#}T{SV=3r)bWyۺ*zomrW9vn{; m5}@G`I׹sQsEyFFTbzǐwTgvgrS۱7:d~d=pdlƥ_+*7?WKau$$Cjh4Qbz(/R ,ea;K!M nCNIQi^v][uJ?AloMFHw{ۼ/HԐ~,h[ Q6oҳ^'VFjm:qÄ+ Chȯ7|vGKMN[ڳ*o5AYmj37uQh6O=페[ܶ4-hk4Mb:ښȭvءDd&ap75rR<6mEnOUxK };"wSo8S{ "|b\_ŷ嫱8NkSi^ {Ahj5U}6_;A$êKNL;OGyŶM {9q#69mK;<"fV}WYF&: O~ 1f/~,4߶uc~ɪmZ5&C^S4q8HTc4])#UsJe{hS7eᇍz7AQ]clOdQna`J&cK.Whh4۶$'G:- 3 =pX. wr9nv$mbvL/v~oPot*{EW]~;X$mF)H,ݑr E^[5ԑ dH-ۺ,MC5@MQIvTG~m+m~3q@^9 hIFUu6 B?0 uB-ߑnnvwEvkQ&/Yf|GvTj{bľʋM>R疖qSv9w`{ҧ%Qo:[=!m~Yj3"hk4MMuT5JG28wY_C&i:|-d o^]`Wђw%qGhipb6ko{KAZ?:ҧЧx#+"f^q O]U򺱷4VSm/DXTX}]Qp G'~llOr)o& KYۋOGxvvS+6\b__}_T!H=yuūM>`7{^,#lB~3A< MmF!ZDu~g O\}V)ޏo^韋S&Ae-BQ&fЩ8m7w.ue#nn;R`jLb\XAuKܺw=3MVmkj~h4ZMef+6R϶S42Ruq铍S)?;d6mYuP!katumM}=m'Qs#փ]n}Ym==xA0`!\io;4&k3/k!/Ӣh47 צext/O,ؚo#!SygY7,Q9ӎc`5 HdVEm;g]U_y:)"TxړOT^*4-m2׈WyMk Ll%xV`DohSGEi/.V_͖oТh47MWn޾mǕ)/F>K;o6ӎcIĐbKgξ_ٲ0f9OQEww| R "{b+W+3U"/_h["#ߜ['%H,T}Z5PqH . S>^'ry[uVHl5.HX) /cXC< Vp[{{c]W*R3 ,ڭZ J-o_Yyۖ-`{͕Z5ک{/*4Xvqe 䖍>${xxx5mB0z?aq N+Xg*7U<ՉtUV 7߳J'Ll-ٱImTXТh47ˢ5]׃0].c8YȖ^_ Jl:? qz!PpUmBT>ٰʫhqWϵ+I`[9WV/VUU ګ.Cyܱ9Uudo5}?h4M]k(@sΗ~ `]ʟZr8uǂm7N̲읽 /68ad B԰ҞC Mee3q.ltyikiTu(L{.øZz}A* ԰~zt-FST`m|^vCp߉[s'mX?8۾&oNʗK $`s Lc-:+j:[)0\SoxS5}L/5=Ͱs臘Y2o,{ sT=nMgmNo8w%yilТh4ME{qIˮg ]٦Bo*7l5 ^V,%Sx?¿[BmK_!vҿ#˾ n{tih#j]kqaGuRQlԿo<>Wy"]TuxJE4TZǬ=zKD`ڳ.vaX]?ao=E[hIV7Ԍ26yrىW%YVlbkˎdL/6ÏLBvłm^V١!(M}n$LtkQflM7wQo $ɤf3CUdWkA~QP"aM57ؤE[h>W7{&6c*j*׈7{6zL}񎢖%6vYy|j|+11l;ǘJr6~>{}3X6wQ;E"9j٧mwQ+-";ȎMz҄0Wkg߿WU"{ޮ<\r쭦FՔ@m\c~+52OU;+C7vؽ$xؠX:l8ZZ/̍pgʅ$+j,drdFӽ_oQk?@7p^5~ [ VyjD(՗t*BH֢h4Ey{"Rl 0<·^9iF{s{B`3a^v 8×N 9-&L^ } X d;17雅lH:R+׋}~mZ7:[bwU}Mk֯<-FS]@mHR\,@y{ #۫-]{f3sK&, RzNs"4n-ھd)6̣PfD1|31sSo[9FԮ wB:О͈4QCڳl5MfǟO?#n@te^G0.QPF޶y-FS]8{6~-wlE$ٶzu8 9١^RRZ ^]s݋1W;&j׽ Z.O;W+9,o7}-.gDaZx͟~/&+}=m_Oc73tŎK=5;9$UHVHbęx SرW2A^J Գ׎]֢h4Ueuy%NUIGlw).j%|ٕqp9* IDAT%>aR[~f*G>۾(͏TD,,! F!qk +ǖs0c_a[ G-f[F ;BhƄ7{6Η;s &ab~8N}ZȦFvh{"=Ihr1<`(QB6%lxg[| fSB`&̭h/w$kWF8{6]z1Wl 0t9 0WǒZ˞,؟ k ={$mX=Ι/YrIq} ΁5w/¶ӱlp ƌd7lp齌;g'K!懓^&.WuP]#te9ɦ d*^$6K fvnIĮbQ1~B w;_u -d]k3hk4MubZ&+Q'vJ$Uv)hZ`s2,2GVN`[JSauBf"l.ĭ/svFh0<ꪊvˢJZ ʂ="o;AB v器hyI`i^SF8{޷f.ڈC) WSR12E.mWkjJ9TFy|]Q3x6ΗޏKmj*U&&xp[,xt-F/YA^/ Ϳ_E[hg{d,"Цt"UYԉEevz FZJ0 /(kThPy #Y'^^SBVeB]H||ɞQl;oN\wBkrW<::qۙh%`n8DQ%}B0lxn;$MFKh|mFj=Lf/rLB|?!`ۍiLg|̚Ϻ81Z]Em)N%[pDH96]3]g_l[\@B|!U,־8G]Bd̒ƟnBY[{'Mm}Qy[ &K6Af+-ɇUmu^%OܮE[hK#qؔS< iwͬdrxZ\yyW#Yl[louۇG\a4L%I%Q^"Q(4Llj^^Wؼ ~/o6jۑ-G6rpH} Rַokd6<_ j`[ u43^!Ç#|Soc@~8| ȷ` I`~9[ebKVǞoR} NW3 2ܓli\ޠ=N쭦F8{6qDlVi!+;9SE+ǝ/T1γ \22"b"y]5ٷ(s>-/o2< \ G~|sOsm,闋{ cJ2_n}1ޟȜUNaWQdF!)";Cz|]p R { "<*]@٥ ߑ^BJԽxp`gax׉'aWGJZ5i$g6Eh"&^Otw>~ >$ [F8@`ۏnڣuBA_w> zz1' Dش7?Yk&}pWd{{2 {ݰRQ9y`q"S zH%*'펔l+"ͩוh4gS?mE;Thfa[g3X;q0)t<#}dɻCH-"aAG#O6ŧ ay vwMJVP7Ș? ] 5@mrS)pGp;q7n))y9'86TN;SѴhk4Mav\eѭN^s'x ^{ԵȻ_?v uʻ>z2^ݟ`XA2!G }HDJf !$O{X57v tp9ҟK>&mP& I&8K)H'Y^{Qг +m?o䊋vXtwFҢh4UӇ`=Ec!3~=I~ڿ*!Q{cN^o>sX{Uoᳶl IƬd^$3jɘ5C0}iߏ#qc xK扛ۺ*N/H+PS_}`a K؜Tq/n%=;kh4H-2_ ɪ|Ӄ9o>Sc@6·g.y1G˞O~8ЋO^y>pȧ`kϰn$"}L1C8` 9&_2WM J|Fh[\]+;K;-h 64q3gviNJ4FS:΋`\דCRB3qxR`*Gȡo#;X KQ׎{H</ˆ=OҴ=c.ݛVxFfV{>{ 7B:nwUf4O}w>{=-X!N|עh4UB4j.Dw[L7a5YÊ3:cKvB00w玶XgFyS qꠢkYievj}Yk&ES1NwtShfN꫊[ܶUWKCfolLB8 -FS8{:jX-_0) 9'L7ew~܁O;{BRpx"Aq ﶺ/^ilϧЃx3Xxi36s8ǖE%>>c{?~ fGirDAU*/[F,>Ĕa`Nz? }`o"fs.:ßMH3w70;xM3!'!Wz?(|X0 ,yY|эĩl Ҋ09#KԀ7Ә\n(޶vFneo/h+ޱ?)h`?\%aN쭦F8{XƗcG3fi*?pwo͛ň  >x1I1g$Yk&sj Ze[vt*G>s|^;?B@fЂ1Z̡C21Ƴ5:*rhg=mfo{ .-dB"rWja_, 'mFj=Loߘ]BUv5qӥ?1]UyprW/pv^??[ǧ)v}ӛC\ιPMdkm|8=g a\Pp"W/x< kx AL >pxųLri3>òElץFn6CW,}KS;ˬ$U BVjeߛ_a֢h4eP=[Ѿ%_zki?XKSB8MEU,>TGs5FM2φ*3>LG/}SM^{-9~)5ܕm?dž mGW' > 91]6Ѷ[rۖ<-FS]4_t:\Vby8f { reI9UVI֪{f %uP. oC ws %~R/gowAJ?KC-&wWOFm KE[VIQR-FS=P'@mxw|w;,rN$cYٌi6rɗQ8osvW0i߼ᆭY# R)>kgN6[6{~x*a=Kұ }Un/}篨Vv|vFelj/_@^,D|g7 -&6jh4wǚ.^A!+aܩ*.Fyg w60F62Wyceg|9uyqځNn\|턴ʵxه-?`]±tOp%ars=YL.6VK)D](Fk'=/D3Edg'컈r쭦FT`u9q#+r~q0\02,ʊZJ"ܐN!dWU7mql7--eqzlB!O8qvtSgJ:o"5 ";U.~U B+WolD;ʄJ mF)w!m< aUmwHL_.w0 t'7djQNx\/02W|MZ<젊UgWoJZ"4bwsF?AZ;7~KzwQ;ٶNԁh.v^߼FWr=7s捛4]NFT'9XڍK6Vx;ȫ>y 雍9|^~d|vܸHMA3{^A[T|yi9+WO&́w2m=. ?8-k _ l] B zǶcv =ڴmYe5,ڑ+m@mukkS^[FєAE֦j~mssA+?<U򲧤"{?ZT_ذ "ŃQX;YËr˩CHHkԗ^}Oʴ7H Joe]i\TSY=c%l6#ӶڤGGhK>nei +2>V=Ng^=kih4ꦢ띑dۼfxהּ}dۑ)Ȟ(;n'H9sx<7t'7-%+$iocwG? !ir;hf!Tޡ9NTǺGv7iFX崇fDwWm][>䗃K .vȎ"<ɉkGbW wv]ڲGcdAl_Ӭ UZ4.¯!{Ahj5QQkxh.Sv Ү\D?9jb MS2O4hc*nbzGw_.So8J=]V.}_X'Q!'kk//;'044' i¯GVFj*{Z M''+ M ME(6^zs-!Ï`1&J^?!U$܆ǖEyf!ݐ؞|BI  ,>o,l{ca5܋7`C'%;nJ7vDtze*f#;%ءm^tQmFYTm$:-HÊK r6T_6|-ޅioc.K);?-Yc,z?+_nI`|J)M#/|:9Xv7sV_JczB䄍y|0gW&L}2LZV5[/`A"O;ɇ)gTvluHY mF)8h6mlçvE<3[r^}_PM'+h2)>cj;/l7TǕfQ ݎm)H9~ñ\=S\55H?.[$Q}fOx'c"s1yfFxx|ɼsu@v%R1*y1S q*l-FSUq6]Ev7h՗_.;_t@Prp߁|+ң>F{AH[H9wG& ^н\]gGX#܊E㊖ M7I1~ߣHߣ*o9Ƭ^=j%j-Zv.i!/R`E{d$+,f Vhk4MTa{WX*"dn{xn!OFwA=f\iA1xHNO!B0ɁhOB#B0] "!X"| G|Q#/ -W3m+چosĖImp{x& %,N ve}_v"; r֢h4e|AUaMT߶吏Sgh"FGFlO=zƔTΘ HV AVZY2>H$Ñ q&GoH5C%kB/LcfOJG-.6,&0?LMs:,g]%w*y84VSn݈%m#A_CT-dǐoA~F ;0}_- "NamlyIȻv0͏5ɘ3]pO71z'[ڈWkւi Z2'NC߇0RRW'{3P>,d:-FST`I갿5Ei;y9MQtnZ^xd*܆zu|~vu7ޣ1U<؇rHW?ZVfĖ޶E'9 B+/"vEǼ7_aMj)p2,E^v5Mhk4MTxn\~a9_oGv"4)j*ZMi  =C6Km2 "&AK|)عҟM"z6^Iq*Dn5cyo6m-Z0Y_,h|JWqi^}n˂/ ?+n 'w4ubWUۗc^=GBn$کC6 L[Up죕LwSZtfB6On#ZWkV -^ԡ|N+fvrṪig6x{ޝGWYyOd03NόF&ЎvqTjwX:qr֎ ; .Ȯ$!sDQPTdIB E["uKY>s $~>gҪs}5͡ 7y}s۹w>+j)ZRn C;8-Ğ~~AȜMD4ЎѻV!*cVwTwO+:ءzկSryϸc[q=4s4Eޫ]Q߽X<4T^{YU~|4ծA4euU&uSš vN蒴ժZ+ZOjk~M{B'(zmZuznpښ3Rܩ CT>qV׵RpM+M 5zhwVY#]}Ⱦh;jULvz^g1\OLy\[w*I߫A4JM'W&[CIݬ\7y\]_~5Wsw]6)Nᗉ\~Zf>+qz/!}W5 {9 ~O>`;bmWx"7(gDRUZ9#J3rrFU24㷏kʽhzT\jEmЭ\:館>vͷxS Z:yjNŭ}I=~h7iiÊ>hI/U?R 5h{[~?w*ط}UL CT>aJFTnj*蟬`cCDGTdD"#*ge?R-R}y0MV=ۿ&]Mۊlۣ`ߧ /8/fyۜ9RG}Yxp⌗uk?tMR Ϛ>VuUpr Wףیwx`oqc߫=wġZ`-;IWrEn8_;)e+']ԟEi.Sڠv"k=+񻤮=.Aɓrh/{ 'OY_|C:⊥VE϶c) UlWڛ^' u`Ǯ' [P]}4{;JM.S* p\_;Rʞg~zԵT:<%Elm8Zs_rMtW{ r%6hKTo|^⃵谡Z7aV{ԁ~g]ꭗ)ߨOw&sc+a?94Zr!_^qk鹱;r&v~ҥ*cJ;u5ޜOA]1q'JOѲ7k*=NSW_+l]s`'|Wn]ar`shiBN:/`Z=[,W'\mWIswWf22%sرúbPZ;aVEVoY5A}rrfR^Q?> v5_nj^Ob׼]Q.1<94Zz)'M[pɝ{3xj),*)ozP實jKޓܱ z"Z3J[FqZU2~VYo=#-z:?+kHO Jiҫu(upT *[ 6*8?8Zʫ&R*O׺.Kcj%p9qB[=2)~9|v㮯FnE;hʖdiIڒޛgR;#hC?Լ{ȝ}q{w<5a]%_(~ ǓV]kUskWau^e~`shit}~,Jrz㊤k6I6]3[}TyԼ`>-ضWwTiϕ\Mt;v\ u͟+[yc/|Kq ҨGUң;>%^$!Zj@}YxrA'N9|L'|8-HKs>UuvG95r HQ/S57(Z{I%4-c>:`Rb%O7?9tj^ŕ=>"C4lGթQ/X8@"WթSv[f"]]sXQjTna{\`,WPu5Ws;c8涮Y˕}ݬfkJQ5+~gc-|:5+7tE"'YaؕuEnPa]uJzjt:ߨPzDmR‹9 Y/.iKfşjܭ+ۘCjURcU^a_E *e}JEz+{VOe=Cc+sxwe>Ͱݕ9&PW*XG}][W*Eׇr@A Y ?2KJKOrx_vX.ؠ)pJ:_~yQxOM/g{TI *TE h+裼Ɋ/mE_xт>^hM ?dA8 =CV{XJ=u\Q.CS%/.196&yY/醔0}c׾seٹT2Bܦꐂ=l/P5`3 ֏PP{U^ 6NP%])ع!\G7rb}wzVECn=qh@^ -i|U,+ umûy 7g^\T%MWDm9X= :z5 R#jU-ަ.o(YӖzkK%.K>\mڭV?W\*jV!F+>6+E)TŒE%R%?U9J:jU)L39K×ʥңjΟt2u%=?7`g%mY<{ϭPWeԺ*Rq%k_NUiNW|TŇԪ3)8K[1RK^Xu(i|%xE]^\Ι!(Յ 67z_⊎(hx0Q|!*\WYVv/S%3_SⴅJd}zkKzkKzkKzk]ȗfܬfܬ@Dd=5%Mf=5%Mf=5%Mf=g<׬4<׬4<׬4<׬4<׬4<׬4<׬4<גDK^K~:WDd=5%Mf=5%Mf=5%Mf=5%Mf=5%Mf=5%Mf=䉹"%yY/i"7yY/i"7yY/i"7yY/i"7y%OȗfܬfܬmmmmmmmmmmmmmmmmmmE{jWE),V*B oh6h6h6ho)j U%WHqh6h6h6hgcm;T~ ڠ ڠ ڠ A%/*͛a)nmmmt.n|͗Y[ifnmmm6F;g8ڠ ڠ ڠ ک&'`+-TDNܠ ڠ ڠ ڠvVʛmmm{?me ڠ ڠ ڠh6h6h6h+`7dmmmmfOQ6jAAA?9ʩd=ڠ ڠ ڠhrq-T6h6h6h/ue,69iAAA;~hKlA0'a>.mEհ AAA;?rS: ڠ ڠ ڠh}^rji{oSh6h6hv] W&:՚} ڠ ڠ ڠhOl%O9h6h6h6hj#h<}:߸u'@AAڥtюY|,_>.KgbycOo4w ڠ ڠ v+r1mhaO,mmmL]y-hǟ7:Jmmm폙\MC{5압 mWmmm,AAAct׻Y AAAc766h6h6hv 7YA{5앷GBwkmmmV>|q(kh}{Z ڠ ڠ ڠ {ʲڠ ڠ ڠ A Y=m|~mmmVv]Y=msAAA]!zE^UKm(|kW2ѕe/z@AAA[y8db2Q]8{y$2M{Ch6h6h6h+07^#_ڠ ڠ ڠh7{T8~HjM0'zAAAcqeL=˩AAA;S3t-`w ڠ ڠ L,Q }Rh4Kqs?h6h6h6hBr(nD2I,b:mmmmeJwьKW|Gmmm5 ܯm -jb ڠ ڠ ڠ h\!9&/+nW75mmmmM!)v~T -V2AAAA;;hڃjmmmmmmmmmmmmmmm ?EHGgOIENDB`janet-1.41.2/tools/msi/LICENSE.rtf000066400000000000000000000023721514534607600164460ustar00rootroot00000000000000{\rtf1\ansi\ansicpg1252\deff0\nouicompat\deflang1033{\fonttbl{\f0\fnil\fcharset0 Arial;}} {\*\generator Riched20 10.0.18362}\viewkind4\uc1 \pard\sa200\sl276\slmult1\fs16\lang9 Copyright (c) 2026 Calvin Rose and contributors\par Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:\par The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.\par THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.\par } janet-1.41.2/tools/msi/janet.wxs000066400000000000000000000244601514534607600165150ustar00rootroot00000000000000 $(var.Description) $(var.WebPage) $(var.Manufacturer) ALLUSERS=1 NOT ALLUSERS=1 WixAppFolder = "WixPerMachineFolder" janet-1.41.2/tools/patch-header.janet000066400000000000000000000002301514534607600174160ustar00rootroot00000000000000# Patch janet.h (def [_ janeth janetconf output] (dyn :args)) (spit output (string/replace `#include "janetconf.h"` (slurp janetconf) (slurp janeth))) janet-1.41.2/tools/removecr.janet000066400000000000000000000004271514534607600167230ustar00rootroot00000000000000# Remove carriage returns from file. Since piping things on # windows may add bad line endings, we can just force removal # with this script. (def fname ((dyn :args) 1)) (def source (slurp fname)) (def new-source (string/replace-all "\r" "" source)) (spit fname new-source :wb) janet-1.41.2/tools/symcharsgen.c000066400000000000000000000040531514534607600165440ustar00rootroot00000000000000/* * Copyright (c) 2026 Calvin Rose * * Permission is hereby granted, free of charge, to any person obtaining a copy * of this software and associated documentation files (the "Software"), to * deal in the Software without restriction, including without limitation the * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or * sell copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included in * all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS * IN THE SOFTWARE. */ #include #include static int is_symbol_char_gen(uint8_t c) { if (c & 0x80) return 1; if (c >= 'a' && c <= 'z') return 1; if (c >= 'A' && c <= 'Z') return 1; if (c >= '0' && c <= '9') return 1; return (c == '!' || c == '$' || c == '%' || c == '&' || c == '*' || c == '+' || c == '-' || c == '.' || c == '/' || c == ':' || c == '<' || c == '?' || c == '=' || c == '>' || c == '@' || c == '^' || c == '_'); } int main() { printf("static const uint32_t symchars[8] = {\n "); for (int i = 0; i < 256; i += 32) { uint32_t block = 0; for (int j = 0; j < 32; j++) { block |= is_symbol_char_gen(i + j) << j; } printf("0x%08x%s", block, (i == (256 - 32)) ? "" : ", "); } printf("\n};\n"); return 0; } janet-1.41.2/tools/tm_lang_gen.janet000066400000000000000000000237171514534607600173620ustar00rootroot00000000000000# Helper to generate core library mappings for janet # Used to help build the tmLanguage grammar. Emits # the entire .tmLanguage file for janet. # Use dynamic binding and make this the first # expression in the file to not pollute (all-bindings) (setdyn :allsyms (array/concat @["break" "def" "do" "var" "set" "fn" "while" "if" "quote" "quasiquote" "unquote" "upscope" "splice"] (all-bindings))) (def allsyms (dyn :allsyms)) (def grammar-template ````` fileTypes janet foldingStartMarker \{ foldingStopMarker \} foldingStartMarker \[ foldingStopMarker \] foldingStartMarker \( foldingStopMarker \) keyEquivalent ^~L name Janet patterns include #all repository all patterns include #comment include #parens include #brackets include #braces include #readermac include #string include #longstring include #literal include #corelib include #r-number include #dec-number include #hex-number include #keysym include #symbol comment captures 1 name punctuation.definition.comment.janet match (#).*$ name comment.line.janet braces begin (@?{) captures 1 name punctuation.definition.braces.begin.janet end (}) captures 1 name punctuation.definition.braces.end.janet patterns include #all brackets begin (@?\[) captures 1 name punctuation.definition.brackets.begin.janet end (\]) captures 1 name punctuation.definition.brackets.end.janet patterns include #all parens begin (@?\() captures 1 name punctuation.definition.parens.begin.janet end (\)) captures 1 name punctuation.definition.parens.end.janet patterns include #all readermac match [\'\~\;\,] name punctuation.other.janet literal match (?<![\.:\w_\-=!@\$%^&?/<>*])(true|false|nil)(?![\.:\w_\-=!@\$%^&?/<>*]) name constant.language.janet corelib match (?<![\.:\w_\-=!@\$%^&?/<>*])(%ALLSYMBOLS%)(?![\.:\w_\-=!@\$%^&?/<>*]) name keyword.control.janet keysym match (?<![\.:\w_\-=!@\$%^&?/<>*]):[\.:\w_\-=!@\$%^&?/<>*]* name constant.keyword.janet symbol match (?<![\.:\w_\-=!@\$%^&?/<>*])[\.a-zA-Z_\-=!@\$%^&?/<>*][\.:\w_\-=!@\$%^&?/<>*]* name variable.other.janet hex-number match (?<![\.:\w_\-=!@\$%^&?/<>*])[-+]?0x([_\da-fA-F]+|[_\da-fA-F]+\.[_\da-fA-F]*|\.[_\da-fA-F]+)(&[+-]?[\da-fA-F]+)?(?![\.:\w_\-=!@\$%^&?/<>*]) name constant.numeric.hex.janet dec-number match (?<![\.:\w_\-=!@\$%^&?/<>*])[-+]?([_\d]+|[_\d]+\.[_\d]*|\.[_\d]+)([eE&][+-]?[\d]+)?(?![\.:\w_\-=!@\$%^&?/<>*]) name constant.numeric.decimal.janet r-number match (?<![\.:\w_\-=!@\$%^&?/<>*])[-+]?\d\d?r([_\w]+|[_\w]+\.[_\w]*|\.[_\w]+)(&[+-]?[\w]+)?(?![\.:\w_\-=!@\$%^&?/<>*]) name constant.numeric.decimal.janet string begin (@?") beginCaptures 1 name punctuation.definition.string.begin.janet end (") endCaptures 1 name punctuation.definition.string.end.janet name string.quoted.double.janet patterns match (\\[nevr0zft"\\']|\\x[0-9a-fA-F]{2}|\\u[0-9a-fA-F]{4}|\\U[0-9a-fA-F]{6}) name constant.character.escape.janet longstring begin (@?)(`+) beginCaptures 1 name punctuation.definition.string.begin.janet 2 name punctuation.definition.string.begin.janet end \2 endCaptures 1 name punctuation.definition.string.end.janet name string.quoted.triple.janet nomatch match \S+ name invalid.illegal.janet scopeName source.janet uuid 3743190f-20c4-44d0-8640-6611a983296b `````) # Now we generate the bindings in the language. (def- escapes {(get "|" 0) `\|` (get "-" 0) `\-` (get "+" 0) `\+` (get "*" 0) `\*` (get "^" 0) `\^` (get "$" 0) `\$` (get "?" 0) `\?` 38 "&" 60 "<" 62 ">" 34 """ 39 "'" 47 "/"}) (defn- escape "Escape special characters for HTML and regex encoding." [str] (def buf @"") (loop [byte :in str] (if-let [rep (get escapes byte)] (buffer/push-string buf rep) (buffer/push-byte buf byte))) buf) (def pattern (string/join (map escape allsyms) "|")) (print (string/replace "%ALLSYMBOLS%" pattern grammar-template)) janet-1.41.2/tools/update_copyright.janet000066400000000000000000000023401514534607600204470ustar00rootroot00000000000000(def usage (string "usage: janet " (first (dyn :args)) " ")) (def ignores [".git"]) (def exts ["LICENSE" "Makefile" ".build" ".c" ".h" ".janet"]) (defn arg [i] (defn bail [] (print usage) (quit)) (if-not (= 3 (length (dyn :args))) (bail) (if-let [val (get (dyn :args) i)] val (bail)))) (def oy (arg 1)) (def ny (arg 2)) (def od (string "Copyright (c) " oy " Calvin Rose")) (def nd (string "Copyright (c) " ny " Calvin Rose")) (defn join [dir name] (os/realpath (string dir "/" name))) (defn add-children [dir paths] (loop [name :in (os/dir dir) :unless (has-value? ignores name)] (array/push paths (join dir name)))) (defn ends-in? [exts s] (find (fn [ext] (string/has-suffix? ext s)) exts)) (defn update-disclaimer [path] (if-let [_ (ends-in? exts path) oc (slurp path) pos (string/find od oc) nc (string (string/slice oc 0 pos) nd (string/slice oc (+ pos (length od))))] (spit path nc))) (def cwd (os/cwd)) (def paths (if (string/has-suffix? "janet" cwd) @[cwd] @[(join cwd "..")])) (loop [p :in paths] (if (= :directory ((os/stat p) :mode)) (add-children p paths) (update-disclaimer p)))