diff --git a/.builds/freebsd.yml b/.builds/freebsd.yml index a52fe10e..70febddf 100644 --- a/.builds/freebsd.yml +++ b/.builds/freebsd.yml @@ -10,3 +10,9 @@ tasks: gmake test sudo gmake install sudo gmake uninstall +- build-sanitizers: | + cd janet + CFLAGS="-g -O2 -fsanitize=address,undefined" gmake + gmake test + sudo gmake install + sudo gmake uninstall diff --git a/.builds/openbsd.yml b/.builds/openbsd.yml index 47989c22..894a558a 100644 --- a/.builds/openbsd.yml +++ b/.builds/openbsd.yml @@ -1,4 +1,4 @@ -image: openbsd/7.6 +image: openbsd/7.7 sources: - https://git.sr.ht/~bakpakin/janet packages: @@ -10,13 +10,17 @@ tasks: gmake gmake test doas gmake install - gmake test-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 diff --git a/.github/cosmo/setup b/.github/cosmo/setup index 9de92d41..f515e105 100644 --- a/.github/cosmo/setup +++ b/.github/cosmo/setup @@ -1,19 +1,19 @@ #!/bin/sh set -e -sudo apt update +sudo apt-get update sudo apt-get install -y ca-certificates libssl-dev\ - qemu qemu-utils qemu-user-static\ + 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/3.3.3/cosmocc-3.3.3.zip +wget https://github.com/jart/cosmopolitan/releases/download/4.0.2/cosmocc-4.0.2.zip mkdir -p cosmocc cd cosmocc -unzip ../cosmocc-3.3.3.zip +unzip ../cosmocc-4.0.2.zip # register cd /sc/cosmocc diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index 689dd540..c5389e91 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -17,7 +17,7 @@ jobs: runs-on: ${{ matrix.os }} strategy: matrix: - os: [ ubuntu-latest, macos-13 ] + os: [ ubuntu-latest ] steps: - name: Checkout the repository uses: actions/checkout@master @@ -46,7 +46,7 @@ jobs: runs-on: ${{ matrix.os }} strategy: matrix: - os: [ macos-latest ] + os: [ macos-latest, macos-15-intel ] steps: - name: Checkout the repository uses: actions/checkout@master diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 2ace8070..6b56aadb 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -12,7 +12,7 @@ jobs: runs-on: ${{ matrix.os }} strategy: matrix: - os: [ ubuntu-latest, macos-latest, macos-13 ] + os: [ ubuntu-latest, ubuntu-24.04-arm, macos-latest, macos-14, macos-15-intel ] steps: - name: Checkout the repository uses: actions/checkout@master @@ -21,6 +21,20 @@ jobs: - name: Test the project run: make test + test-posix-sanitizers: + name: Build and test on POSIX systems with sanitizers turned on + runs-on: ${{ matrix.os }} + strategy: + matrix: + os: [ ubuntu-latest ] + steps: + - name: Checkout the repository + uses: actions/checkout@master + - name: Compile the project + run: make clean && CFLAGS="-g -O2 -fsanitize=address,undefined" make + - name: Test the project + run: make test + test-windows: name: Build and test on Windows strategy: @@ -42,6 +56,27 @@ jobs: shell: cmd run: build_win dist + test-windows-sanitizers: + name: Build and test on Windows with sanitizers + strategy: + matrix: + os: [ windows-latest ] + 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: set SANITIZE=1 & build_win + - name: Test the project + shell: cmd + run: set VERBOSE=1 & 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: @@ -136,3 +171,22 @@ jobs: 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 diff --git a/.gitignore b/.gitignore index df79cc1f..1a4d46fe 100644 --- a/.gitignore +++ b/.gitignore @@ -12,6 +12,7 @@ janet /src/include/generated/*.h janet-*.tar.gz dist +/tmp # jpm lockfile lockfile.janet diff --git a/CHANGELOG.md b/CHANGELOG.md index e0537afe..ca28cfa2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,53 @@ All notable changes to this project will be documented in this file. ## Unreleased - ??? +- JANET_PATH will now be searched strictly left-to-right for modules. +- Add `-t` (`--tool`) flag for using installed libraries as command line tools +- Numerous documentation improvements and fixes +- Add support for GNU/Hurd +- Improve pretty printing layout for %M and %m modifiers to be more code-like. +- Add filewatch support to BSD and macos. +- Add linting support for shadowed bindings. +- Add nanboxing support for Linux on ARM64 and turn on nanboxing by default on macos on ARM64 (aarch64). +- ev/thread-chan deadlock bug fixed +- Re-add removed support for non-blocking net/connect on windows with bug fixes. + +## 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`. diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 23470084..a7a12a58 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -37,6 +37,12 @@ may require changes before being merged. 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. +Bot pull requests will not be accepted, and anonymous submissions, including +new accounts, unknown emails, and first time contributors will be subjected +to greater scrutiny and code reivew. Automatically generated and filed bug +reports MAY be ok, if they are of consistent and good quality, such as +OSSFuzz or well constructed CI pipelines. + ## C style For changes to the VM and Core code, you will probably need to know C. Janet is programmed with @@ -61,7 +67,7 @@ ensure a consistent code style for C. ## Janet style -All janet code in the project should be formatted similar to the code in core.janet. +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 @@ -90,3 +96,18 @@ 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. + +## LLMs, Tool Usage, and Transparency + +All usage of Large Language Models (LLMs), Neural Networks, "AI" tools, and +other tools such as software fuzzers or static analyzers must be disclosed. +This applies to pull requests, email patches, bug reports, and any other +meaningful contribution to Janet's source code. Please also refrain from using +generative AI for code that will be embedded in the Janet runtime, which include +all C source files as well as boot.janet. All code should be well +and completely understood by the human author, including test cases. Large and +obviously AI-driven changes will be rejected. Be mindful and transparent on the +copyright implications of any submitted code. We will use discretion when +accepting generated test cases for bug reproductions, one-line bug +fixes, or typo fixes. Often, these can be trivially rewritten by a human to +avoid the problem. diff --git a/LICENSE b/LICENSE index ceaa6a0e..3a254f29 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2025 Calvin Rose and contributors +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 diff --git a/Makefile b/Makefile index 950e3f5e..41b3b99b 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -58,7 +58,6 @@ 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) @@ -224,9 +223,9 @@ build/%.bin.o: src/%.c $(JANET_HEADERS) $(JANET_LOCAL_HEADERS) Makefile ######################## ifeq ($(UNAME), Darwin) -SONAME=libjanet.1.40.dylib +SONAME=libjanet.1.41.dylib else -SONAME=libjanet.so.1.40 +SONAME=libjanet.so.1.41 endif ifeq ($(MINGW_COMPILER), clang) @@ -265,6 +264,7 @@ $(JANET_STATIC_LIBRARY): $(JANET_TARGET_OBJECTS) # Testing assumes HOSTCC=CC TEST_SCRIPTS=$(wildcard test/suite*.janet) +EXAMPLE_SCRIPTS=$(wildcard examples/*.janet) repl: $(JANET_TARGET) $(RUN) ./$(JANET_TARGET) @@ -272,21 +272,26 @@ repl: $(JANET_TARGET) debug: $(JANET_TARGET) $(DEBUGGER) ./$(JANET_TARGET) -VALGRIND_COMMAND=valgrind --leak-check=full --quiet +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_PROGRAMS) +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_PROGRAMS) +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 ./$(JANET_TARGET) -k "$$f"; done + for f in examples/*.janet; do $(VALGRIND_COMMAND) ./$(JANET_TARGET) -k "$$f"; done callgrind: $(JANET_TARGET) - for f in test/suite*.janet; do valgrind --tool=callgrind ./$(JANET_TARGET) "$$f" || exit; done + $(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 ##### @@ -345,6 +350,7 @@ build/janet.pc: $(JANET_TARGET) 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' @@ -354,13 +360,13 @@ install: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.pc mkdir -p '$(DESTDIR)$(JANET_PATH)' mkdir -p '$(DESTDIR)$(LIBDIR)' if test $(UNAME) = Darwin ; then \ - cp $(JANET_LIBRARY) '$(DESTDIR)$(LIBDIR)/libjanet.$(shell $(JANET_TARGET) -e '(print janet/version)').dylib' ; \ + cp $(JANET_LIBRARY) '$(DESTDIR)$(LIBDIR)/libjanet.$(JANET_VERSION).dylib' ; \ ln -sf $(SONAME) '$(DESTDIR)$(LIBDIR)/libjanet.dylib' ; \ - ln -sf libjanet.$(shell $(JANET_TARGET) -e '(print janet/version)').dylib $(DESTDIR)$(LIBDIR)/$(SONAME) ; \ + ln -sf libjanet.$(JANET_VERSION).dylib $(DESTDIR)$(LIBDIR)/$(SONAME) ; \ else \ - cp $(JANET_LIBRARY) '$(DESTDIR)$(LIBDIR)/libjanet.so.$(shell $(JANET_TARGET) -e '(print janet/version)')' ; \ + cp $(JANET_LIBRARY) '$(DESTDIR)$(LIBDIR)/libjanet.so.$(JANET_VERSION)' ; \ ln -sf $(SONAME) '$(DESTDIR)$(LIBDIR)/libjanet.so' ; \ - ln -sf libjanet.so.$(shell $(JANET_TARGET) -e '(print janet/version)') $(DESTDIR)$(LIBDIR)/$(SONAME) ; \ + ln -sf libjanet.so.$(JANET_VERSION) $(DESTDIR)$(LIBDIR)/$(SONAME) ; \ fi cp $(JANET_STATIC_LIBRARY) '$(DESTDIR)$(LIBDIR)/libjanet.a' mkdir -p '$(DESTDIR)$(JANET_MANPATH)' @@ -417,9 +423,6 @@ clean: -rm -rf build vgcore.* callgrind.* -rm -rf test/install/build test/install/modpath -test-install: - echo "JPM has been removed from default install." - help: @echo @echo 'Janet: A Dynamic Language & Bytecode VM' @@ -431,7 +434,8 @@ help: @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 with Valgrind to check for memory leaks' + @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' @@ -441,6 +445,9 @@ help: @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 repl debug valgrind test \ - valtest dist uninstall docs grammar format help compile-commands +.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 diff --git a/README.md b/README.md index 8324e1dd..3cf0c302 100644 --- a/README.md +++ b/README.md @@ -148,8 +148,40 @@ 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. @@ -160,15 +192,18 @@ make make test make repl make install -make install-jpm-git +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. +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 @@ -178,8 +213,13 @@ $ 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, @@ -191,7 +231,8 @@ make CC=gcc-x86 make test make repl make install -make install-jpm-git +make install-spork-git # optional +make install-jpm-git # optional ``` ### FreeBSD @@ -205,7 +246,8 @@ gmake gmake test gmake repl gmake install -gmake install-jpm-git +gmake install-spork-git # optional +gmake install-jpm-git # optional ``` ### NetBSD @@ -320,8 +362,8 @@ 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/janet.c`, which is a single C file -that contains all the source to Janet. This file, along with +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 diff --git a/build_win.bat b/build_win.bat index bb7747bc..e12e89a8 100644 --- a/build_win.bat +++ b/build_win.bat @@ -23,8 +23,18 @@ @set JANET_COMPILE=cl /nologo /Isrc\include /Isrc\conf /c /O2 /W3 /D_CRT_SECURE_NO_WARNINGS /MD /fsanitize=address /Zi /DEBUG @set JANET_LINK=link /nologo clang_rt.asan_dynamic-x86_64.lib clang_rt.asan_dynamic_runtime_thunk-x86_64.lib /DEBUG -@rem set JANET_COMPILE=cl /nologo /Isrc\include /Isrc\conf /c /O2 /W3 /D_CRT_SECURE_NO_WARNINGS /MD -@rem set JANET_LINK=link /nologo +if DEFINED CLANG ( + @set COMPILER=clang-cl.exe +) else ( + @set COMPILER=cl.exe +) +if DEFINED SANITIZE ( + @set "SANITIZERS=/fsanitize=address" +) else ( + @set "SANITIZERS=" +) +@set JANET_COMPILE=%COMPILER% /nologo /Isrc\include /Isrc\conf /c /O2 /W3 /D_CRT_SECURE_NO_WARNINGS /MD %SANITIZERS% +@set JANET_LINK=link /nologo @set JANET_LINK_STATIC=lib /nologo @@ -49,7 +59,7 @@ for %%f in (src\boot\*.c) do ( ) %JANET_LINK% /out:build\janet_boot.exe build\boot\*.obj @if errorlevel 1 goto :BUILDFAIL -@rem note that there is no default sysroot being baked in +@rem note that there is no default syspath being baked in build\janet_boot . > build\c\janet.c @if errorlevel 1 goto :BUILDFAIL diff --git a/examples/chatserver.janet b/examples/chatserver.janet index 534444f5..1fab3710 100644 --- a/examples/chatserver.janet +++ b/examples/chatserver.janet @@ -26,7 +26,7 @@ (broadcast name (string msg))) (print name " disconnected"))))) -(defn main [& args] +(defn main [&] (printf "STARTING SERVER...") (flush) (def my-server (net/listen "127.0.0.1" "8000")) diff --git a/examples/debugger.janet b/examples/debugger.janet index 588e55f3..6d48802c 100644 --- a/examples/debugger.janet +++ b/examples/debugger.janet @@ -132,7 +132,7 @@ "Go to the next breakpoint." [&opt n] (var res nil) - (for i 0 (or n 1) + (repeat (or n 1) (set res (resume (.fiber)))) res) @@ -146,6 +146,6 @@ "Execute the next n instructions." [&opt n] (var res nil) - (for i 0 (or n 1) + (repeat (or n 1) (set res (debug/step (.fiber)))) res) diff --git a/examples/error.janet b/examples/error.janet index e8b9e759..c337ba4a 100644 --- a/examples/error.janet +++ b/examples/error.janet @@ -3,10 +3,10 @@ (defn bork [x] - (defn bark [x] + (defn bark [y] (print "Woof!") - (print x) - (error x) + (print y) + (error y) (print "Woof!")) (bark (* 2 x)) diff --git a/examples/filewatch.janet b/examples/filewatch.janet new file mode 100644 index 00000000..0f0c99b1 --- /dev/null +++ b/examples/filewatch.janet @@ -0,0 +1,14 @@ +### +### example/filewatch.janet ...files +### +### Watch for all changes in a list of files and directories. Behavior +### depends on the filewatch module, and different operating systems will +### report different events. + +(def chan (ev/chan 1000)) +(def fw (filewatch/new chan)) +(each arg (drop 1 (dyn *args* [])) + (filewatch/add fw arg :all)) +(filewatch/listen fw) + +(forever (let [event (ev/take chan)] (pp event))) diff --git a/examples/iterate-fiber.janet b/examples/iterate-fiber.janet index 9d6a49cf..79df4b32 100644 --- a/examples/iterate-fiber.janet +++ b/examples/iterate-fiber.janet @@ -7,13 +7,13 @@ (print "simple yielding") (each item f (print "got: " item ", now " (fiber/status f))) -(def f +(def f2 (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))) +(each item f2 (print "got: " item ", now " (fiber/status f2))) -(print (fiber/status f)) +(print (fiber/status f2)) diff --git a/examples/lazyseqs.janet b/examples/lazyseqs.janet index 1e7452a0..481bc3ed 100644 --- a/examples/lazyseqs.janet +++ b/examples/lazyseqs.janet @@ -4,7 +4,7 @@ # that must be called (realizing it), and the memoized. # Use with (import "./path/to/this/file" :prefix "seq.") -(defmacro delay +(defmacro dolazy "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." @@ -35,7 +35,7 @@ (def x (tuple h t)) (fn [] x)) -(defn empty? +(defn lazy-empty? "Check if a sequence is empty." [s] (not (s))) @@ -55,14 +55,14 @@ [start end &] (if end (if (< start end) - (delay (tuple start (lazy-range (+ 1 start) end))) + (dolazy (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 + (dolazy (def x (s)) (if x (tuple (f (get x HEAD)) (map f (get x TAIL)))))) @@ -76,31 +76,31 @@ [f s] (when (s) (f (head s)) (realize-map f (tail s)))) -(defn drop +(defn lazy-drop "Ignores the first n values of the sequence and returns the rest." [n s] - (delay + (dolazy (def x (s)) - (if (and x (pos? n)) ((drop (- n 1) (get x TAIL)))))) + (if (and x (pos? n)) ((lazy-drop (- n 1) (get x TAIL)))))) -(defn take +(defn lazy-take "Returns at most the first n values of s." [n s] - (delay + (dolazy (def x (s)) (if (and x (pos? n)) - (tuple (get x HEAD) (take (- n 1) (get x TAIL)))))) + (tuple (get x HEAD) (lazy-take (- n 1) (get x TAIL)))))) (defn randseq "Return a sequence of random numbers." [] - (delay (tuple (math/random) (randseq)))) + (dolazy (tuple (math/random) (randseq)))) -(defn take-while +(defn lazy-take-while "Returns a sequence of values until the predicate is false." [pred s] - (delay + (dolazy (def x (s)) (when x (def thehead (get HEAD x)) - (if thehead (tuple thehead (take-while pred (get TAIL x))))))) + (if thehead (tuple thehead (lazy-take-while pred (get TAIL x))))))) diff --git a/examples/life.janet b/examples/life.janet index ac1f8c99..c6483f25 100644 --- a/examples/life.janet +++ b/examples/life.janet @@ -16,8 +16,8 @@ (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)))] + :let [ncount (get neighbor-set coord)] + :when (or (= ncount 3) (and (get cell-set coord) (= ncount 2)))] coord)) (defn draw diff --git a/examples/rtest.janet b/examples/rtest.janet index 9d494674..774d4e46 100644 --- a/examples/rtest.janet +++ b/examples/rtest.janet @@ -2,7 +2,7 @@ (def counts (seq [_ :range [0 100]] 0)) -(for i 0 1000000 +(repeat 1000000 (let [x (math/random) intrange (math/floor (* 100 x)) oldcount (counts intrange)] diff --git a/examples/sample-bad-bundle1/info.jdn b/examples/sample-bad-bundle1/info.jdn new file mode 100644 index 00000000..ed04ca73 --- /dev/null +++ b/examples/sample-bad-bundle1/info.jdn @@ -0,0 +1,3 @@ +@{ + :name "sample-bad-bundle1" +} diff --git a/examples/sample-bad-bundle/badmod.janet b/examples/sample-bad-bundle2/badmod.janet similarity index 100% rename from examples/sample-bad-bundle/badmod.janet rename to examples/sample-bad-bundle2/badmod.janet diff --git a/examples/sample-bad-bundle/bundle.janet b/examples/sample-bad-bundle2/bundle.janet similarity index 100% rename from examples/sample-bad-bundle/bundle.janet rename to examples/sample-bad-bundle2/bundle.janet diff --git a/examples/sample-bad-bundle2/info.jdn b/examples/sample-bad-bundle2/info.jdn new file mode 100644 index 00000000..96936f9f --- /dev/null +++ b/examples/sample-bad-bundle2/info.jdn @@ -0,0 +1,3 @@ +@{ + :name "sample-bad-bundle2" +} diff --git a/examples/threaded-channels.janet b/examples/threaded-channels.janet index c4e1bc1d..de32a2cf 100644 --- a/examples/threaded-channels.janet +++ b/examples/threaded-channels.janet @@ -7,7 +7,7 @@ (ev/give chan (math/random)) (ev/give chan (math/random)) (ev/sleep 0.5) - (for i 0 10 + (repeat 10 (print "giving to channel...") (ev/give chan (math/random)) (ev/sleep 1)) diff --git a/janet.1 b/janet.1 index b2afd7c4..ae64a316 100644 --- a/janet.1 +++ b/janet.1 @@ -156,7 +156,7 @@ Shows the version text and exits immediately. .TP .BR \-s -Read raw input from stdin and forgo prompt history and other readline-like features. +Read raw input from stdin and forgo fancy input, which includes prompt history and other readline-like features. .TP .BR \-e\ code @@ -272,6 +272,12 @@ This variable does nothing in the default configuration of Janet, as PRF is disa 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 diff --git a/meson.build b/meson.build index e5eab3ff..85376b83 100644 --- a/meson.build +++ b/meson.build @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose and contributors +# 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 @@ -20,7 +20,7 @@ project('janet', 'c', default_options : ['c_std=c99', 'build.c_std=c99', 'b_lundef=false', 'default_library=both'], - version : '1.40.0') + version : '1.41.3') # Global settings janet_path = join_paths(get_option('prefix'), get_option('libdir'), 'janet') @@ -72,6 +72,9 @@ 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')) +if get_option('nanbox_pointer_shift') != -1 # -1 is auto-detect + conf.set('JANET_NANBOX_64_POINTER_SHIFT', get_option('nanbox_pointer_shift')) +endif 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')) @@ -292,6 +295,7 @@ test_files = [ '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', diff --git a/meson_options.txt b/meson_options.txt index d055c713..3a833f4f 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -2,6 +2,7 @@ option('git_hash', type : 'string', value : 'meson') option('single_threaded', type : 'boolean', value : false) option('nanbox', type : 'boolean', value : true) +option('nanbox_pointer_shift', type : 'integer', min : -1, max : 4, value : -1) option('dynamic_modules', type : 'boolean', value : true) option('docstrings', type : 'boolean', value : true) option('sourcemaps', type : 'boolean', value : true) diff --git a/misc/completion/README.md b/misc/completion/README.md new file mode 100644 index 00000000..c8c1a080 --- /dev/null +++ b/misc/completion/README.md @@ -0,0 +1,33 @@ +# Shell completions for Janet + +This directory contains shell completion scripts for the `janet` interpreter. + +## Bash + +```sh +# Temporary (current session only) +source /path/to/janet.bash + +# Permanent (system-wide) +sudo cp janet.bash /etc/bash_completion.d/janet + +# Permanent (user only) +cp janet.bash ~/.local/share/bash-completion/completions/janet +``` + +## Zsh + +```sh +# Copy to a directory in your $fpath, e.g.: +cp janet.zsh ~/.zsh/completions/_janet + +# Ensure the directory is in $fpath (add to ~/.zshrc if needed): +# fpath=(~/.zsh/completions $fpath) +# autoload -Uz compinit && compinit +``` + +## Fish + +```sh +cp janet.fish ~/.config/fish/completions/janet.fish +``` diff --git a/misc/completion/janet.bash b/misc/completion/janet.bash new file mode 100644 index 00000000..78dee7ed --- /dev/null +++ b/misc/completion/janet.bash @@ -0,0 +1,42 @@ +# Bash completion for janet +# Install: source this file, or place it in /etc/bash_completion.d/janet +# or ~/.local/share/bash-completion/completions/janet + +_janet() { + local cur prev words cword + _init_completion || return + + local flags="-h -v -s -e -E -d -n -N -r -R -p -q -k -m -c -i -l -w -x --" + + case "$prev" in + -e|-E) + # Argument is Janet source code — no file completion + return + ;; + -m) + # syspath: complete directories + _filedir -d + return + ;; + -c|-l) + # source file: complete .janet files + _filedir janet + return + ;; + -w|-x) + # linting level + COMPREPLY=($(compgen -W ":none :relaxed :normal :strict" -- "$cur")) + return + ;; + esac + + if [[ "$cur" == -* ]]; then + COMPREPLY=($(compgen -W "$flags" -- "$cur")) + return + fi + + # Default: complete .janet files and directories + _filedir janet +} + +complete -F _janet janet diff --git a/misc/completion/janet.fish b/misc/completion/janet.fish new file mode 100644 index 00000000..b8674492 --- /dev/null +++ b/misc/completion/janet.fish @@ -0,0 +1,28 @@ +# Fish completion for janet + +# Disable file completion by default; re-enable for specific flags +complete -c janet -f + +# Flags +complete -c janet -s h -d 'Show usage and exit' +complete -c janet -s v -d 'Show version and exit' +complete -c janet -s s -d 'Read raw stdin (no readline features)' +complete -c janet -s e -r -d 'Execute Janet source string' +complete -c janet -s E -r -d 'Execute Janet expression as short-fn with remaining args' +complete -c janet -s d -d 'Enable debug mode' +complete -c janet -s n -d 'Disable ANSI colors in REPL' +complete -c janet -s N -d 'Enable ANSI colors in REPL' +complete -c janet -s r -d 'Open REPL after executing sources' +complete -c janet -s R -d 'Disable loading user profile in REPL' +complete -c janet -s p -d 'Persistent mode (continue after errors)' +complete -c janet -s q -d 'Hide logo in REPL' +complete -c janet -s k -d 'Compile only (lint), do not execute' +complete -c janet -s i -d 'Treat script as a .jimage file' +complete -c janet -s m -r -d 'Set syspath for module loading' -a '(__fish_complete_directories)' +complete -c janet -s c -r -d 'Precompile source to .jimage' +complete -c janet -s l -r -d 'Import module before script/REPL' -a '(find . -name "*.janet" -printf "%f\n" 2>/dev/null)' +complete -c janet -s w -r -d 'Set warning linting level' -a ':none :relaxed :normal :strict' +complete -c janet -s x -r -d 'Set error linting level' -a ':none :relaxed :normal :strict' + +# File arguments: .janet files and directories +complete -c janet -F -a '*.janet' diff --git a/misc/completion/janet.zsh b/misc/completion/janet.zsh new file mode 100644 index 00000000..24058dc2 --- /dev/null +++ b/misc/completion/janet.zsh @@ -0,0 +1,35 @@ +#compdef janet + +# Zsh completion for janet + +_janet() { + local -a opts + + opts=( + '-h[Show usage and exit]' + '-v[Show version and exit]' + '-s[Read raw stdin (no readline features)]' + '-e[Execute Janet source string]:source code:' + '-E[Execute Janet expression as short-fn with remaining args]:expression:' + '-d[Enable debug mode]' + '-n[Disable ANSI colors in REPL]' + '-N[Enable ANSI colors in REPL]' + '-r[Open REPL after executing sources]' + '-R[Disable loading user profile in REPL]' + '-p[Persistent mode (continue after errors)]' + '-q[Hide logo in REPL]' + '-k[Compile only (lint), do not execute]' + '-i[Treat script as a .jimage file]' + '-m[Set syspath for module loading]:syspath:_directories' + '-c[Precompile source to .jimage]:source:_files -g "*.janet" :output:_files' + '-l[Import module before script/REPL]:module:_files -g "*.janet"' + '-w[Set warning linting level]:level:(none relaxed normal strict)' + '-x[Set error linting level]:level:(none relaxed normal strict)' + '--[End of options]' + '*:script:_files -g "*.janet"' + ) + + _arguments -s $opts +} + +_janet "$@" diff --git a/plan9.mk b/plan9.mk new file mode 100755 index 00000000..77c0bf75 --- /dev/null +++ b/plan9.mk @@ -0,0 +1,49 @@ +$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) + += 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-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] - ,(apply defer [(or dtor :close) binding] body))) + ~(as-macro ,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] - ,(apply defer [(or dtor :close) binding] [truthy]) - ,falsey)) + ~(as-macro ,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] @@ -531,13 +563,13 @@ (case binding :until ~(do (if ,verb (break) nil) ,rest) :while ~(do (if ,verb nil (break)) ,rest) - :let ~(let ,verb (do ,rest)) + :let ~(as-macro ,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) + ~(do (var ,iter ,verb) (while (,> ,iter 0) ,rest (as-macro ,-- ,iter)))) + :when ~(as-macro ,when ,verb ,rest) + :unless ~(as-macro ,unless ,verb ,rest) (error (string "unexpected loop modifier " binding)))))) # 3 term expression @@ -566,106 +598,134 @@ (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)) + `` + Loop over each key in `x` with each key bound to `binding` with + destructuring support. Returns `nil`. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with a suitable `next` method. + `` + [binding x & body] + (each-template binding x :keys body)) (defmacro eachp - "Loop over each (key, value) pair in `ds`. Returns nil." - [x ds & body] - (each-template x ds :pairs body)) + `` + Loop over each (key, value) pair in `x` with each pair bound to + `binding` with destructuring support. Returns `nil`. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [binding x & body] + (each-template binding x :pairs body)) + +(defmacro each + `` + Loop over each value in `x` with each value of `x` bound to + `binding` with destructuring support. Returns `nil`. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [binding x & body] + (each-template binding x :each 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))))) + ~(do (var ,iter ,n) (while (,> ,iter 0) ,;body (as-macro ,-- ,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: + `` + A general purpose loop macro. This macro is similar to the Common + Lisp `loop` macro, although intentionally much smaller in scope. + + The first argument, `head`, 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. + 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. + * `: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` -- 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]. + * `: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` -- loop over a range, stepping downwards. The object + should be a two-element tuple with a start and end value, and an + optional positive step size. The range is half open, [start, + end). - * `:down-to` -- same as :down, but the range is inclusive [start, end]. + * `:down-to` -- same as `:down`, but the range is inclusive [start, + end]. - * `:keys` -- iterate over the keys in a data structure. + * `:keys` -- iterate over the keys in a bytes, indexed, dictionary, + fiber, or abstract type with a suitable `next` method. - * `:pairs` -- iterate over the key-value pairs as tuples in a data structure. + * `:pairs` -- iterate over the key-value pairs as tuples in a bytes, + indexed, dictionary, fiber, or abstract type with suitable `get` + and `next` methods. - * `:in` -- iterate over the values in a data structure or fiber. + * `:in` -- iterate over the values in a bytes, indexed, dictionary, + fiber, or abstract type with suitable `get` and `next` methods. - `loop` also accepts conditionals to refine the looping further. Conditionals are of - the form: + `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: + 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. + * `:while expression` -- breaks from the current loop if + `expression` is falsey. - * `:until expression` -- breaks from the current loop if `expression` is - truthy. + * `: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. + * `: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 + * `: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. + * `:when condition` -- only evaluates the current loop body when + `condition` is truthy. - * `:unless condition` -- only evaluates the current loop body when `condition` - is falsey. + * `:unless condition` -- only evaluates the current loop body when + `condition` is falsey. - The `loop` macro always evaluates to nil. - ``` + The `loop` macro always evaluates to `nil`. + `` [head & body] (loop1 body head 0)) @@ -675,7 +735,7 @@ [head & body] (def $accum (gensym)) (check-empty-body body) - ~(do (def ,$accum @[]) (loop ,head (,array/push ,$accum (do ,;body))) ,$accum)) + ~(do (def ,$accum @[]) (as-macro ,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. @@ -683,21 +743,21 @@ [head & body] (def $accum (gensym)) (check-empty-body body) - ~(do (def ,$accum @[]) (loop ,head (,array/concat ,$accum (do ,;body))) ,$accum)) + ~(do (def ,$accum @[]) (as-macro ,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)) + ~(do (def ,$accum @{}) (as-macro ,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)) + ~(,fiber/new (fn :generate [] (as-macro ,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)`." @@ -710,71 +770,68 @@ (tuple fiber/new (tuple 'fn :fiber-fn '[] ;body) flags)) (defn sum - "Returns the sum of xs. If xs is empty, returns 0." - [xs] + `` + Returns the sum of the values of `x`. If `x` is empty, returns 0. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type with + suitable `get` and `next` methods. + `` + [x] (var accum 0) - (each x xs (+= accum x)) + (each v x (+= accum v)) accum) (defn mean - "Returns the mean of xs. If empty, returns NaN." - [xs] - (if (lengthable? xs) - (/ (sum xs) (length xs)) + `` + Returns the mean of the values of `x`. If empty, returns `math/nan`. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [x] + (if (lengthable? x) + (/ (sum x) (length x)) (do (var [accum total] [0 0]) - (each x xs (+= accum x) (++ total)) + (each v x (+= accum v) (++ total)) (/ accum total)))) (defn geomean - "Returns the geometric mean of xs. If empty, returns NaN." - [xs] - (if (lengthable? xs) + `` + Returns the geometric mean of the values of `x`. If empty, returns + `math/nan`. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [x] + (if (lengthable? x) (do (var accum 0) - (each x xs (+= accum (math/log x))) - (math/exp (/ accum (length xs)))) + (each v x (+= accum (math/log v))) + (math/exp (/ accum (length x)))) (do (var [accum total] [0 0]) - (each x xs (+= accum (math/log x)) (++ total)) + (each v x (+= accum (math/log v)) (++ total)) (math/exp (/ accum total))))) (defn product - "Returns the product of xs. If xs is empty, returns 1." - [xs] + `` + Returns the product of the values of `x`. If `x` is empty, returns + 1. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [x] (var accum 1) - (each x xs (*= accum x)) + (each v x (*= accum v)) 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))) + ~(as-macro ,if-let ,bindings (do ,;body))) (defn comp `Takes multiple functions and returns a function that is the composition @@ -834,14 +891,32 @@ [args] (do-extreme < args)) (defn first - "Get the first element from an indexed data structure." - [xs] - (get xs 0)) + `` + Get the first value in `x`. + + If `x` is a non-empty bytes or indexed type value, return the first + element. + + If `x` is a fiber, return the fiber's last value or `nil` if there + isn't one yet. + + If `x` is an abstract type value with a `get` method, call the method + with a key of `0`. + + In all other cases, return `nil`. + `` + [x] + (get x 0)) (defn last - "Get the last element from an indexed data structure." - [xs] - (get xs (- (length xs) 1))) + `` + Get the final element from `x`. + + `x` can be a bytes, indexed, or abstract type value with suitable + `get` and `length` methods. + `` + [x] + (get x (- (length x) 1))) ## Polymorphic comparisons @@ -960,84 +1035,121 @@ 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?] + `` + Sorts `x` 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 `<`. + + `x` can be a buffer, array, or abstract type with suitable `get`, + `put`, and `length` methods. + `` + [x &opt before?] (default before? <) - (sort-help ind 0 (- (length ind) 1) before?)) + (sort-help x 0 (- (length x) 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))))) + `` + Sorts `x` in-place by calling a function `f` on each element and + comparing the results with `<`. + + `x` can be a buffer, array, or abstract type with suitable `get`, + `put`, and `length` methods. + `` + [f x] + (sort x (fn :sort-by-comp [i j] (< (f i) (f j))))) (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 `<`.`` + `` + Returns a new sorted array based on an indexed type `ind`. 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 `<`.`` + `` + Returns a new sorted array based on an indexed type `ind`. + Comparison is done by invoking a function `f` on each element and + comparing the results 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) + `` + Also know as fold-left in many languages, this function transforms + `x` by successively applying a function `f` to values from `x` and + an updating "accumulator" value. `f` is a function of 2 arguments, + `(f acc v)`, where `acc` starts as `init` and `v` is the next value + in `x`. `f` returns a value that will be used as `acc` in the next + call to `f`. The ultimate return value is that of the final call to + `f`. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [f init x] + (var acc init) + (each v x (set acc (f acc v))) + acc) (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)) + `` + The 2-argument version of `reduce`. Instead of taking an explicit + initial value, the first value of `x` is used instead. If `x` is + empty, returns `nil`. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [f x] + (var k (next x)) (if (= nil k) (break nil)) - (var res (in ind k)) - (set k (next ind k)) + (var res (in x k)) + (set k (next x k)) (while (not= nil k) - (set res (f res (in ind k))) - (set k (next ind k))) + (set res (f res (in x k))) + (set k (next x 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] + `` + Similar to `reduce`, but accumulates successive results of applying + `f` into a new array. The last element in the array is what would be + the return value from `reduce`. The `init` value is not added + directly as the first value of the new array, i.e. the returned + array will have the same number of elements as `x`. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [f init x] (var res init) (def ret @[]) - (each x ind (array/push ret (set res (f res x)))) + (each v x (array/push ret (set res (f res v)))) 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)) + `` + The 2-argument version of `accumulate`. Instead of taking an + explicit initial value, the first value of `x` is used instead. If + `x` is empty, returns an empty array. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [f x] + (var k (next x)) (def ret @[]) (if (= nil k) (break ret)) - (var res (in ind k)) + (var res (in x k)) (array/push ret res) - (set k (next ind k)) + (set k (next x k)) (while (not= nil k) - (set res (f res (in ind k))) + (set res (f res (in x k))) (array/push ret res) - (set k (next ind k))) + (set k (next x k))) ret) (defmacro- map-aggregator @@ -1088,113 +1200,147 @@ (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] + `` + Map a function `f` over every value in `x` and return an array of + results. + + Also functions variadically, i.e. takes additional arguments, with + suitable changes to the arity of `f`. `f` is called with both values + from `x` and additional arguments, and only as many times as the + length of the shortest of `x` and each element of `xs`. If `x` or + any element of `xs` is empty, returns an empty array. + + `x` and elements of `xs` can be values of type bytes, indexed, + dictionary, fiber, or abstract with suitable `get` and `next` + methods. + `` + [f x & xs] (def res @[]) - (map-template :map res f ind inds) + (map-template :map res f x xs) 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] + `` + Map a function `f` over every value in `x` and use `array/concat` to + concatenate the results. + + Also functions variadically, i.e. takes additional arguments, with + suitable changes to the arity of `f`. `f` is called with both values + from `x` and additional arguments, and only as many times as the + length of the shortest of `x` and each element of `xs`. If `x` or + any element of `xs` is empty, returns an empty array. + + `x` and elements of `xs` can be values of type bytes, indexed, + dictionary, fiber, or abstract with suitable `get` and `next` + methods. + `` + [f x & xs] (def res @[]) - (map-template :mapcat res f ind inds) + (map-template :mapcat res f x xs) 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] + `` + Given a predicate, take only elements from `x` for which `(pred + element)` is truthy. Returns a new array. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [pred x] (def res @[]) - (each item ind - (if (pred item) - (array/push res item))) + (each v x + (if (pred v) (array/push res v))) 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] + `` + Count the number of values in `x` for which applying `pred` yields a + truthy value. + + Also functions variadically, i.e. takes additional arguments, with + suitable changes to the arity of `pred`. `pred` is called with both + values from `x` and additional arguments, and only as many times as + the length of the shortest of `x` and each element of `xs`. If `x` + or any element of `xs` is empty, returns 0. + + `x` and elements of `xs` can be values of type bytes, indexed, + dictionary, fiber, or abstract with suitable `get` and `next` + methods. + `` + [pred x & xs] (var res 0) - (map-template :count res pred ind inds) + (map-template :count res pred x xs) 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] + `` + Given a predicate `pred`, return a new array containing the truthy + results of applying `pred` to each value in `x`. + + Also functions variadically, i.e. takes additional arguments, with + suitable changes to the arity of `pred`. `pred` is called with both + values from `x` and additional arguments, and only as many times as + the length of the shortest of `x` and each element of `xs`. If `x` + or any element of `xs` is empty, returns an empty array. + + `x` and elements of `xs` can be values of type bytes, indexed, + dictionary, fiber, or abstract with suitable `get` and `next` + methods. + `` + [pred x & xs] (def res @[]) - (map-template :keep res pred ind inds) + (map-template :keep res pred x xs) 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) + `` + Find the index of `x` for which `pred` is true. If not found, return + `dflt` if provided, or `nil` otherwise. + + `x` can be a bytes, indexed, dictionary, or abstract type with + suitable `get` and `next` methods. + `` + [pred x &opt dflt] + (var k (next x 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))) + (while (not= nil k) + (when (pred (in x k)) (set ret k) (break)) + (set k (next x k))) 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) + `` + Find the first value in `x` that satisfies `pred`. If not found, + return `dflt` if given, or `nil` otherwise. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [pred x &opt dflt] + (var k (next x 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))) + (while (not= nil k) + (def item (in x k)) + (when (pred item) (set ret item) (break)) + (set k (next x k))) 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)) + `` + Find the first key associated with a value `val` in `x`, acting like + a reverse lookup. Will not look at dictionary prototypes. If not + found, return `dflt` if given, or `nil` otherwise. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [val x &opt dflt] + (var k (next x nil)) (var ret dflt) (while (not= nil k) - (when (= (in ind k) x) (set ret k) (break)) - (set k (next ind k))) + (when (= (in x k) val) (set ret k) (break)) + (set k (next x k))) ret) (defn- take-n-slice @@ -1324,14 +1470,24 @@ (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))) + `` + Check if `x` maps `key` to a non-nil value. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with a suitable `get` method. + `` + [x key] + (not= nil (get x 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))) + `` + Checks if `x` contains `value`. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type with + suitable `get` and `next` methods. + `` + [x value] + (not= nil (index-of value x))) (defdyn *defdyn-prefix* ``Optional namespace prefix to add to keywords declared with `defdyn`. Use this to prevent keyword collisions between dynamic bindings.``) @@ -1424,7 +1580,7 @@ (tuple n @[]))) (def sym (gensym)) (def parts (array/concat @[h sym] t)) - ~(let [,sym ,last] (if ,sym ,(keep-syntax! n parts)))) + ~(as-macro ,let [,sym ,last] (if ,sym ,(keep-syntax! n parts)))) (reduce fop x forms)) (defmacro -?>> @@ -1440,7 +1596,7 @@ (tuple n @[]))) (def sym (gensym)) (def parts (array/concat @[h] t @[sym])) - ~(let [,sym ,last] (if ,sym ,(keep-syntax! n parts)))) + ~(as-macro ,let [,sym ,last] (if ,sym ,(keep-syntax! n parts)))) (reduce fop x forms)) (defn- walk-ind [f form] @@ -1454,6 +1610,12 @@ (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 @@ -1544,60 +1706,85 @@ (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] + `` + Evaluates to the last element of `x` if all preceding elements are + truthy, true if `x` is empty, or otherwise to the first falsey + element. + + `x` can be a bytes, indexed. dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [x] (var res true) - (loop [x :in ind :while res] - (set res x)) + (loop [v :in x :while res] + (set res v)) res) (defn any? - ``Evaluates to the last element of `ind` if all preceding elements are falsey, - otherwise evaluates to the first truthy element.`` - [ind] + `` + Evaluates to the last element of `x` if all preceding elements are + falsey, `nil` if `x` is empty, or otherwise to the first truthy + element. + + `x` can be a bytes, indexed. dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [x] (var res nil) - (loop [x :in ind :until res] - (set res x)) + (loop [v :in x :until res] + (set res v)) res) (defn reverse! - `Reverses the order of the elements in a given array or buffer and returns it - mutated.` - [t] + `` + Reverses the order of the values in `x` and returns it mutated. + + `x` can be a buffer, array, or abstract type with suitable + `get`, `length`, and `put` methods. + `` + [x] (var i 0) - (var j (length t)) + (var j (length x)) (while (< i (-- j)) - (def ti (in t i)) - (put t i (in t j)) - (put t j ti) + (def v (in x i)) + (put x i (in x j)) + (put x j v) (++ i)) - t) + x) (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) + `` + Reverses the order of the values in `x`. If `x` is a bytes type, + returns a buffer, otherwise returns an array. + + `x` can be a bytes, indexed, fiber, or abstract type with suitable + `get` and `next` methods. + `` + [x] + (if (lengthable? x) (do - (var n (length t)) - (def ret (if (bytes? t) + (var n (length x)) + (def ret (if (bytes? x) (buffer/new-filled n) (array/new-filled n))) - (each v t + (each v x (put ret (-- n) v)) ret) - (reverse! (seq [v :in t] v)))) + (reverse! (seq [v :in x] 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] + `` + Returns a table where the keys of `x` are the values, and the values + are the keys. If multiple keys in `x` are mapped to the same value, + only one of those values will become a key in the returned table. + + `x` can be a bytes, indexed, dictionary, or abstract type with a + `suitable next` method. + `` + [x] (def ret @{}) - (loop [k :keys ds] - (put ret (in ds k) k)) + (loop [k :keys x] + (put ret (in x k) k)) ret) (defn zipcoll @@ -1616,20 +1803,37 @@ 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) + `` + Use the keys `ks` to look up a nested value in `x`. If a value is + not found, will return `dflt` if provided, or `nil` otherwise. + + `x` can be a suitable indexed, dictionary, or abstract type with a + `get` method. + + `ks` can be an indexed or abstract type with `get` and `next` + methods. + `` + [x ks &opt dflt] + (var d x) (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) + `` + Update a value in `x`. Looks into a nested spot in `x` identified by + the keys `ks` and replaces the value found there with `f` applied to + that value and any values passed and available in `args`. Missing + spots will be replaced with tables and `f` is passed `nil` instead + of a found value. Returns `x` modified. + + `x` can be a suitable array, table or abstract type with `get` and + `put` methods. + + `ks` can be an indexed or abstract type with suitable `get` and + `length` methods. + `` + [x ks f & args] + (var d x) (def len-1 (- (length ks) 1)) (if (< len-1 0) (error "expected at least 1 key in ks")) (forv i 0 len-1 @@ -1643,14 +1847,22 @@ (def last-key (get ks len-1)) (def last-val (get d last-key)) (put d last-key (f last-val ;args)) - ds) + x) (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) + `` + Use the keys `ks` to put a value `v` into a nested spot in + `x`. Missing spots will be replaced with tables. Returns `x` + modified. + + `x` can be a suitable array, table or abstract type with `get` and + `put` methods. + + `ks` can be an indexed or abstract type with suitable `get` and + `length` methods. + `` + [x ks v] + (var d x) (def len-1 (- (length ks) 1)) (if (< len-1 0) (error "expected at least 1 key in ks")) (forv i 0 len-1 @@ -1664,38 +1876,53 @@ (def last-key (get ks len-1)) (def last-val (get d last-key)) (put d last-key v) - ds) + x) (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))) + `` + For a given key in `x`, replace its associated value with the result + of applying `f` to that value. If `args` are provided, they will be + passed along to `f` as well. Returns updated `x`. + + `x` can be a buffer, array, table, or suitable abstract type with + `get` and `put` methods. + `` + [x key f & args] + (def old (get x key)) + (put x key (f 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 + `` + Merges multiple dictionaries into table `tab`. If a key appears in + more than one dictionary in `dicts`, then later values replace any + previous ones. Returns `tab`. + `` + [tab & dicts] + (loop [c :in dicts 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] + `` + Merges multiple dictionaries into one new table. If a key appears in + more than one dictionary in `dicts` then later values replace any + previous ones. Returns the new table. + `` + [& dicts] (def container @{}) - (loop [c :in colls + (loop [c :in dicts key :keys c] (put container key (in c key))) container) (defn keys - "Get the keys of an associative data structure." + `` + Get the keys of `x` as an array. + + `x` can be a bytes, indexed, dictionary, or abstract type with a + suitable `next` method. + `` [x] (if (lengthable? x) (do @@ -1708,7 +1935,12 @@ (seq [k :keys x] k))) (defn values - "Get the values of an associative data structure." + `` + Get the values of `x` as an array. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` [x] (if (lengthable? x) (do @@ -1721,7 +1953,13 @@ (seq [v :in x] v))) (defn pairs - "Get the key-value pairs of an associative data structure." + `` + Return an array of tuples of the key-value pairs of `x`. For bytes + and indexed types, the integer indices are considered the keys. + + `x` can be a bytes, indexed, dictionary, or abstract type with + suitable `get` and `in` methods. + `` [x] (if (lengthable? x) (do @@ -1734,49 +1972,72 @@ (seq [p :pairs x] p))) (defn frequencies - "Get the number of occurrences of each value in an indexed data structure." - [ind] + `` + Returns a table of occurrences of each value in `x`. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with `get` and `next` methods. + `` + [x] (def freqs @{}) - (each x ind - (def n (in freqs x)) - (set (freqs x) (if n (+ 1 n) 1))) + (each v x + (put freqs v (inc (in freqs v 0)))) 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] + `` + Group values of `x` 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 values of `x`. The values of the table are arrays + of all values of `x` for which `f` called on the value equals that + corresponding key. + + `x` can be a bytes, indexed, dictionary, fiber, or abstract type + with suitable `get` and `next` methods. + `` + [f x] (def ret @{}) - (each x ind - (def y (f x)) + (each v x + (def y (f v)) (if-let [arr (get ret y)] - (array/push arr x) - (put ret y @[x]))) + (array/push arr v) + (put ret y @[v]))) 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] + `` + Partition values of `x` by a function `f`. Partitions split when `f` + applied to a value changes result when iterating to the next value + of `x`. Returns a new array of arrays. + + `x` can be a bytes, indexed, fiber, or abstract type with suitable + `get` and `next` methods. + `` + [f x] (def ret @[]) (var span nil) - (var category nil) - (var is-new true) - (each x ind - (def y (f x)) + (var categ nil) + (var new? true) + (each v x + (def y (f v)) (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)))) + new? (do (set new? false) (set categ y) (set span @[v]) (array/push ret span)) + (= categ y) (array/push span v) + (do (set categ y) (set span @[v]) (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)) + `` + Returns an array of the values of each element of `xs`, interleaved. + If the elements of `xs` do not all have the same number of values, + the shortest element of `xs` determines the number of values from + each element of `xs` that are contained in the returned array. + + Each element of `xs` can be a bytes, indexed, fiber, or abstract + type with suitable `get` and `next` methods. + `` + [& xs] + (mapcat tuple ;xs)) (defn distinct "Returns an array of the deduplicated values in `xs`." @@ -1787,24 +2048,28 @@ 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))) + `` + Appends the depth-first traversal of an indexed type `ind` into a + given array `into`. Returns `into`. + `` + [into ind] + (each elt ind + (if (indexed? elt) + (flatten-into into elt) + (array/push into elt))) 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)) + `` + Returns a depth-first traversal of an indexed type `ind` as a new + array. + `` + [ind] + (flatten-into @[] ind)) (defn kvs - ``Takes a table or struct and returns and array of key value pairs - like `@[k v k v ...]`. Returns a new array.`` + ``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))) @@ -1820,24 +2085,28 @@ 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)) + `` + Returns an array of the values of `x` separated by `sep`. + + `x` can be a bytes, indexed, fiber or abstract type with suitable + `get` and `next` methods. + `` + [sep x] + (var k (next x nil)) (if (not= nil k) - (if (lengthable? ind) + (if (lengthable? x) (do - (def ret (array/new-filled (- (* 2 (length ind)) 1) sep)) + (def ret (array/new-filled (- (* 2 (length x)) 1) sep)) (var i 0) (while (not= nil k) - (put ret i (in ind k)) - (set k (next ind k)) + (put ret i (in x k)) + (set k (next x 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))) + (def ret @[(in x k)]) + (while (not= nil (set k (next x k))) + (array/push ret sep (in x k))) ret)) @[])) @@ -1856,13 +2125,20 @@ ret) (defn partition - ``Partition an indexed data structure `ind` into tuples - of size `n`. Returns a new array.`` - [n ind] + `` + Partition the values of `x` into tuples of size `n`. Returns a new + array. + + `n` should be a non-negative integer. + + `x` can be a bytes, indexed, fiber, or abstract type with suitable + `get` and `next` methods. + `` + [n x] (cond - (indexed? ind) (partition-slice tuple/slice n ind) - (bytes? ind) (partition-slice string/slice n ind) - (partition-slice tuple/slice n (values ind)))) + (indexed? x) (partition-slice tuple/slice n x) + (bytes? x) (partition-slice string/slice n x) + (partition-slice tuple/slice n (values x)))) ### ### @@ -2019,6 +2295,11 @@ (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 @@ -2038,11 +2319,10 @@ (def isarr (or (= t :array) (and (= t :tuple) (= (tuple/type pattern) :brackets)))) (when isarr (array/push anda (get-length-sym s)) - (def pattern-len - (if-let [rest-idx (find-index (fn [x] (= x '&)) pattern)] - rest-idx - (length pattern))) - (array/push anda [<= pattern-len (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 @@ -2054,7 +2334,7 @@ isarr (eachp [i sub-pattern] pattern # stop recursing to sub-patterns if the rest sigil is found - (when (= sub-pattern '&) + (when (or (= sub-pattern '$) (= sub-pattern '&)) (break)) (visit-pattern-2 anda gun preds s i sub-pattern)) @@ -2100,11 +2380,15 @@ (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 ,;defs (and ,;preds))) + (def pred-join ~(do ,;unused-defs (and ,;preds))) (array/push anda pred-join)) - (emit-branch (tuple/slice anda) ['do ;defs expression])) + # 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]) @@ -2151,7 +2435,7 @@ (defn expand-bindings [x] (case (type x) :array (map expand-bindings x) - :tuple (tuple/slice (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))) @@ -2159,11 +2443,11 @@ (defn expanddef [t] (def last (in t (- (length t) 1))) (def bound (in t 1)) - (tuple/slice - (array/concat - @[(in t 0) (expand-bindings bound)] - (tuple/slice t 2 -2) - @[(recur last)]))) + (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))) @@ -2174,10 +2458,10 @@ (if (symbol? t1) (do (def args (map recur (tuple/slice t 3))) - (tuple 'fn t1 (in t 2) ;args)) + (keep-syntax t (tuple 'fn t1 (in t 2) ;args))) (do (def args (map recur (tuple/slice t 2))) - (tuple 'fn t1 ;args)))) + (keep-syntax t (tuple 'fn t1 ;args))))) (defn expandqq [t] (defn qq [x] @@ -2232,35 +2516,44 @@ 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] + `` + Apply `pred` to values of `x`. Return true if all results are truthy; + if any result is falsey, stop applying `pred` and return the result. + + Also functions variadically, i.e. takes additional arguments, with + suitable changes to the arity of `pred`. `pred` is called with both + values from `x` and additional arguments, and only as many times as + the length of the shortest of `x` and each element of `xs`. If `x` + or any element of `xs` is empty, returns true. + + `x` and elements of `xs` can be values of type bytes, indexed, + dictionary, fiber, or abstract with suitable `get` and `next` + methods. + `` + [pred x & xs] (var res true) - (map-template :all res pred ind inds) + (map-template :all res pred x xs) 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] + `` + Returns `nil` if applying `pred` to every value in `x` results in + only falsey values, otherwise returns the first truthy result + encountered. + + Also functions variadically, i.e. takes additional arguments, with + suitable changes to the arity of `f`. `f` is called with both values + from `x` and additional arguments, and only as many times as the + length of the shortest of `x` and each element of `xs`. If `x` or + any element of `xs` is empty, returns `nil`. + + `x` and elements of `xs` can be values of type bytes, indexed, + dictionary, fiber, or abstract with suitable `get` and `next` + methods. + `` + [pred x & xs] (var res nil) - (map-template :some res pred ind inds) + (map-template :some res pred x xs) res) (defn freeze @@ -2291,9 +2584,11 @@ x)) (defn thaw - `Thaw an object (make it mutable) and do a deep copy, making + ``` + 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.` + types will not be recursively thawed, but all other types will. + ``` [ds] (case (type ds) :array (walk-ind thaw ds) @@ -2303,6 +2598,19 @@ :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=`.`` @@ -2371,15 +2679,16 @@ (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))) + ~(as-macro ,let [,old-entry (,dyn ',name)] + (def ,entry (as-macro ,or ,old-entry @{:ref @[nil]})) + (,setdyn ',name ,entry) + (def ,f ,fbody) + (,put-in ,entry [:ref 0] ,f) + (,merge-into ,entry ',metadata) + ,f))) ### ### @@ -2387,6 +2696,7 @@ ### ### +(def- max-shortfn-params 9999) # Less than 0xFFFF so we have enough registers for internal use (defmacro short-fn ``` Shorthand for `fn`. Arguments are given as `$n`, where `n` is the @@ -2417,8 +2727,10 @@ :else (do (def num (scan-number (string/slice x 1))) - (if (nat? num) + (if num (do + (assertf (nat? num) "expected indexed parameter, got %s" x) + (assertf (<= num max-shortfn-params) "too many short-fn parameters (%s)" x) (saw-special-arg num) (symbol prefix x)) x))) @@ -2637,17 +2949,17 @@ (var resumeval nil) (def f (fiber/new - (fn [] + (fn :compile-and-lint [] (array/clear lints) (def res (compile source env where lints)) - (unless (empty? lints) + (when (next 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 + (each [level line col msg] (distinct lints) # some macros might cause code to be duplicated. Avoid repeated messages. (def lvl (get lint-levels level 0)) (cond (<= lvl lint-error) (do @@ -2807,7 +3119,8 @@ (defmacro comptime "Evals x at compile time and returns the result. Similar to a top level unquote." [x] - (eval x)) + (def y (eval x)) + y) (defmacro compif "Check the condition `cnd` at compile time -- if truthy, compile `tru`, else compile `fals`." @@ -2835,7 +3148,8 @@ (defn- check-dyn-relative [x] (if (string/has-prefix? "@" x) x)) (defn- check-relative [x] (if (string/has-prefix? "." x) x)) -(defn- check-not-relative [x] (if-not (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)) @@ -2887,8 +3201,20 @@ (array/insert mp curall-index [(string ":cur:/:all:" ext) loader check-relative]) mp) -# Don't expose this externally yet - could break if custom module/paths is setup. -(defn- module/add-syspath +(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) + +(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. @@ -2909,7 +3235,16 @@ (module/add-paths "/init.janet" :source) (module/add-paths ".janet" :source) (module/add-paths ".jimage" :image) -(array/insert module/paths 0 [(fn is-cached [path] (if (in (dyn *module-cache* module/cache) path) path)) :preload check-not-relative]) +(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 @@ -2937,20 +3272,22 @@ or :image if the module is found, otherwise a tuple with nil followed by an error message. ``` - [path] + [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]) - (break)) + (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]) - (break)))))) + (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) @@ -3061,7 +3398,7 @@ (os/exit 1)) (put env :exit true) (def buf @"") - (with-dyns [*err* buf *err-color* false] + (with-dyns [*err* buf] (bad-parse x y)) (set exit-error (string/slice buf 0 -2))) (defn bc [&opt x y z a b] @@ -3070,7 +3407,7 @@ (os/exit 1)) (put env :exit true) (def buf @"") - (with-dyns [*err* buf *err-color* false] + (with-dyns [*err* buf] (bad-compile x nil z a b)) (set exit-error (string/slice buf 0 -2)) (set exit-fiber y)) @@ -3125,17 +3462,20 @@ (defn- require-1 [path args kargs] - (def [fullpath mod-kind] (module/find path)) + (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 (kargs :fresh) (in mc fullpath))] + (if-let [check (if-not (get kargs :fresh) (in mc fullpath))] check - (if (ml fullpath) + (if (get ml fullpath) (error (string "circular dependency " fullpath " detected")) (do - (def loader (if (keyword? mod-kind) (mls mod-kind) mod-kind)) + (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) @@ -3174,7 +3514,7 @@ (def prefix (or (and as (string as "/")) prefix - (string (last (string/split "/" path)) "/"))) + (string (first (string/split "." (last (string/split "/" path)))) "/"))) (merge-module env newenv prefix ep only)) (defmacro import @@ -3235,7 +3575,6 @@ [&opt env local] (env-walk keyword? env local)) - (defdyn *doc-width* "Width in columns to print documentation printed with `doc-format`.") @@ -3689,7 +4028,7 @@ (def digits (inc (math/floor (math/log10 end)))) (def fmt-str (string "%" digits "d: %s")) (for i beg end - (eprin " ") # breakpoint someday? + (eprin " ") (eprin (if (= i cur) "> " " ")) (eprintf fmt-str i (get lines i)))) (let [[sl _] (sourcemap pc)] @@ -3796,13 +4135,16 @@ (default env (make-env)) (default chunks (fn :chunks [buf p] - (getline - (string - "repl:" - ((:where p) 0) - ":" - (:state p :delimiters) "> ") - buf env))) + (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)) @@ -3823,13 +4165,16 @@ (defn ev/call ``` Call a function asynchronously. - Returns a fiber that is scheduled to run the function. + 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 fiber. This is shorthand for `(ev/go (fn [] ;body))`." + `` + Run some code in a new task fiber. This is shorthand for + `(ev/go (fn [] ;body))`." + `` [& body] ~(,ev/go (fn :spawn [&] ,;body))) @@ -3881,9 +4226,9 @@ `` [sec & body] (with-syms [f] - ~(let [,f (coro ,;body)] - (,ev/deadline ,sec nil ,f) - (,resume ,f)))) + ~(as-macro ,let [,f (as-macro ,coro ,;body)] + (,ev/deadline ,sec nil ,f) + (,resume ,f)))) (defn- cancel-all [chan fibers reason] (each f fibers (ev/cancel f reason)) @@ -3902,23 +4247,33 @@ (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 `` - Run a number of fibers in parallel on the event loop, and join when they complete. - Returns the gathered results in an array. + 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] - (with-syms [chan res fset ftemp] - ~(do - (def ,fset @{}) - (def ,chan (,ev/chan)) - (def ,res @[]) - ,;(seq [[i body] :pairs bodies] - ~(do - (def ,ftemp (,ev/go (fn :ev/gather [] (put ,res ,i ,body)) nil ,chan)) - (,put ,fset ,ftemp ,ftemp))) - (,wait-for-fibers ,chan ,fset) - ,res)))) + ~(,ev/go-gather ,(seq [body :in bodies] ~(fn :ev/gather [] ,body))))) (compwhen (dyn 'net/listen) (defn net/server @@ -3932,7 +4287,7 @@ "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)))) + (ev/go (fn :net/server-handler [] (net/accept-loop s handler)))) s)) ### @@ -4003,15 +4358,15 @@ (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)))) + ~(as-macro ,defn ,alias ,;meta [,;formal-args] + (,ffi/call (,(delay (make-ptr))) (,(delay (make-sig))) ,;formal-args)) + ~(as-macro ,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))) + ~(as-macro ,ffi/defbind-alias ,name ,name ,ret-type ,;body))) ### ### @@ -4052,7 +4407,6 @@ Other arguments to `flycheck` are the same as `dofile`. Returns nil. ``` [path &keys kwargs] - (def mc @{}) (def new-env (make-env (get kwargs :env))) (put new-env *flychecking* true) (put new-env *module-cache* @{}) @@ -4080,8 +4434,17 @@ true)) (defn- is-safe-def [thunk source env where] - (if (no-side-effects (last source)) - (thunk))) + (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] @@ -4114,19 +4477,15 @@ (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)) + (string (os/realpath (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)) + (string (os/realpath (dyn *syspath*)) s "bundle" s bundle-name s filename)) (defn- get-manifest-filename [bundle-name] @@ -4194,7 +4553,7 @@ (spit manifest-name b)) (defn bundle/manifest - "Get the manifest for a give installed bundle" + "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) @@ -4205,7 +4564,7 @@ (def manifest (bundle/manifest bundle-name)) (def dir (os/cwd)) (def workdir (get manifest :local-source ".")) - (def fixed-syspath (bundle-rpath (dyn *syspath*))) + (def fixed-syspath (os/realpath (dyn *syspath*))) (try (os/cd workdir) ([_] (print "cannot enter source directory " workdir " for bundle " bundle-name))) @@ -4219,7 +4578,15 @@ (put new-env *syspath* fixed-syspath) (with-env new-env (put new-env :bundle-dir (bundle-dir bundle-name)) # get the syspath right - (require (string "@syspath/bundle/" bundle-name))))) + (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] @@ -4256,7 +4623,9 @@ nil) (defn bundle/uninstall - "Remove a bundle from the current syspath" + ``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) @@ -4292,8 +4661,8 @@ order) (defn bundle/prune - "Remove all orphaned bundles from the syspath. An orphaned bundle is a bundle that is - marked for :auto-remove and is not depended on by any other bundle." + ``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)) @@ -4322,33 +4691,44 @@ (not (not (os/stat (bundle-dir bundle-name) :mode)))) (defn bundle/install - "Install a bundle from the local filesystem. The name of the bundle will be inferred from the bundle, or passed as a parameter :name in `config`." + ``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 path (os/realpath 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 + (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" path) + (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 infofile - (def infofile-dest (bundle-file bundle-name "info.jdn")) - (when infofile-src (copyfile infofile-src infofile-dest)) - # Copy aliased initfile - (def initfile-alias (string path s "bundle.janet")) - (def initfile-dest (bundle-file bundle-name "init.janet")) - (when (fexists initfile-alias) (copyfile initfile-alias initfile-dest)) + # 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)) @@ -4357,8 +4737,7 @@ (merge-into man config) (sync-manifest man) (edefer (do (print "installation error, uninstalling") (bundle/uninstall bundle-name)) - (when (os/stat infofile-dest :mode) - (def info (-> infofile-dest slurp parse)) + (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)) @@ -4366,12 +4745,13 @@ (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 module (get-bundle-module bundle-name)) (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) + (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) @@ -4381,15 +4761,21 @@ (when check (do-hook module bundle-name :check man))) (print "installed " bundle-name) - (when (get man :has-bin-script) + (when (or (get man :has-exe) + # remove eventually + (get man :has-bin-script)) (def binpath (string (dyn *syspath*) s "bin")) - (eprintf "executable scripts have been installed to %s" binpath)) + (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." + ``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)) @@ -4400,7 +4786,7 @@ (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*))) + (def syspath (os/realpath (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)) @@ -4419,9 +4805,9 @@ 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 necesarry to replace a package without - breaking any dependencies." + ``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 @{})) @@ -4448,7 +4834,7 @@ bundle-name) (defn bundle/add-directory - "Add a directory during the install process relative to `(dyn *syspath*)`" + "Add a directory during an install relative to `(dyn *syspath*)`." [manifest dest &opt chmod-mode] (def files (get-files manifest)) (def s (sep)) @@ -4466,7 +4852,7 @@ "Given a file path, figure out which bundle installed it." [path] (var ret nil) - (def rpath (bundle-rpath path)) + (def rpath (os/realpath path)) (each bundle-name (bundle/list) (def files (get (bundle/manifest bundle-name) :files [])) (def has-file (index-of rpath files)) @@ -4476,7 +4862,7 @@ ret) (defn bundle/add-file - "Add files during an install relative to `(dyn *syspath*)`" + "Add a file during an install relative to `(dyn *syspath*)`." [manifest src &opt dest chmod-mode] (default dest src) (def files (get-files manifest)) @@ -4493,9 +4879,9 @@ absdest) (defn bundle/add - "Add files and directories during a bundle 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." + ``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)) @@ -4510,20 +4896,31 @@ (errorf "bad path %s - file is a %s" src mode))) (defn bundle/add-bin - `` - Shorthand for adding scripts during an install. Scripts will be installed to - `(string (dyn *syspath*) "/bin")` by default and will be set to be executable. - `` - [manifest src &opt dest chmod-mode] + ``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 dest (last (string/split s src))) + (default filename (last (string/split s src))) (default chmod-mode 8r755) (os/mkdir (string (dyn *syspath*) s "bin")) - (put manifest :has-bin-script true) - (bundle/add-file manifest src (string "bin" s dest) chmod-mode)) + (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" + "Reinstall all bundles." [&keys configs] (each bundle (bundle/topolist) (bundle/reinstall bundle ;(kvs configs))))) @@ -4535,12 +4932,14 @@ ### # conditional compilation for reduced os -(def- getenv-alias (if-let [entry (in root-env 'os/getenv)] (entry :value) (fn [&]))) +(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))] + [env subargs] + (when-let [main (module/value env 'main true)] (def guard (if (get env :debug) :ydt :y)) (defn wrap-main [&] (main ;subargs)) @@ -4549,7 +4948,9 @@ (while (fiber/can-resume? f) (set res (resume f res)) (when (not= :dead (fiber/status f)) - ((debugger-on-status env) f res))))) + ((debugger-on-status env) f res))) + (break true)) + false) (defdyn *args* "Dynamic bindings that will contain command line arguments at program start.") @@ -4583,6 +4984,7 @@ "-nocolor" "n" "-color" "N" "-library" "l" + "-tool" "t" "-install" "b" "-reinstall" "B" "-uninstall" "u" @@ -4592,6 +4994,17 @@ "-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.` @@ -4605,23 +5018,21 @@ (var raw-stdin false) (var handleopts true) (var exit-on-error true) - (var colorize true) - (var debug-flag false) (var compile-only false) - (var warn-level nil) - (var error-level nil) (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) + (def paths (string/split path-sep jp)) + (loop [i :down-to [(- (length paths) 1) 1]] (module/add-syspath (get paths i))) (setdyn *syspath* (first paths))) (if-let [jprofile (getenv-alias "JANET_PROFILE")] (setdyn *profilepath* jprofile)) - (set colorize (and - (not (getenv-alias "NO_COLOR")) - (os/isatty stdout))) + (apply-color + (and + (not (getenv-alias "NO_COLOR")) + (os/isatty stdout) + (os/isatty stderr))) (defn- get-lint-level [i] @@ -4652,6 +5063,7 @@ --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 + --tool (-t) lib args... : Use a module before processing more arguments, and then call it's `main` function --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 @@ -4671,10 +5083,10 @@ "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 [&] (set colorize false) 1) - "N" (fn [&] (set colorize true) 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 &] + "c" (fn :c-switch [i &] (def path (in args (+ i 1))) (def e (dofile path)) (def output-path @@ -4687,15 +5099,24 @@ (set no-file false) 3) "-" (fn [&] (set handleopts false) 1) - "l" (fn l-switch [i &] + "l" (fn :l-switch [i &] (import* (in args (+ i 1)) :prefix "" :exit exit-on-error) 2) - "e" (fn e-switch [i &] + "t" (fn :t-switch [i &] + (set should-repl false) + (set no-file false) + (def lib (in args (+ i 1))) + (def tool-env (require lib :exit exit-on-error)) + (def subargs (tuple/slice args (+ i 2))) + (put tool-env *args* subargs) + (assertf (run-main tool-env subargs) "no main found for module %s" lib) + math/inf) + "e" (fn :e-switch [i &] (set no-file false) (eval-string (in args (+ i 1))) 2) - "E" (fn E-switch [i &] + "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)) @@ -4728,9 +5149,9 @@ (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 [&] (set debug-flag true) 1) - "w" (fn [i &] (set warn-level (get-lint-level i)) 2) - "x" (fn [i &] (set error-level (get-lint-level i)) 2) + "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 &] @@ -4751,25 +5172,15 @@ (do (def env (load-image (slurp arg))) (put env *args* subargs) - (put env *lint-error* error-level) - (put env *lint-warn* warn-level) - (when debug-flag - (put env *debug* true) - (put env *redef* true)) - (run-main env subargs arg)) + (run-main env subargs)) (do (def env (make-env)) (put env *args* subargs) - (put env *lint-error* error-level) - (put env *lint-warn* warn-level) - (when debug-flag - (put env *debug* true) - (put env *redef* true)) (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))))) + (run-main env subargs))))) (set i lenargs)))) (if (or should-repl no-file) @@ -4784,21 +5195,9 @@ (when-let [custom-prompt (get env *repl-prompt*)] (break (custom-prompt p))) (def [line] (parser/where p)) (string "repl:" line ":" (parser/state p :delimiters) "> ")) - (defn getstdin [prompt buf _] - (file/write stdout prompt) - (file/flush stdout) - (file/read stdin :line buf)) - (when debug-flag - (put env *debug* true) - (put env *redef* true)) (def getter (if raw-stdin getstdin getline)) (defn getchunk [buf p] (getter (getprompt p) buf env)) - (setdyn *pretty-format* (if colorize "%.20Q" "%.20q")) - (setdyn *err-color* (if colorize true)) - (setdyn *doc-color* (if colorize true)) - (setdyn *lint-error* error-level) - (setdyn *lint-warn* error-level) (when-let [profile.janet (dyn *profilepath*)] (dofile profile.janet :exit true :env env) (put env *current-file* nil)) @@ -4837,7 +5236,9 @@ # 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))) + # Drop simple types, otherwise we get odd issues when loading foreign data from a different Janet version. + # It also doesn't usually save any space to encode these anyway. + (if (or (string? v) (keyword? v) (number? v)) (put load-dict k nil))) (merge-into load-image-dict load-dict) (def image @@ -4914,14 +5315,15 @@ "src/core/wrap.c"]) # Print janet.c to stdout - (print "/* Amalgamated build - DO NOT EDIT */") + (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 (has-value? boot/args "image-only") + (unless image-only (print "\n/* " fname " */") (print "#line 0 \"" fname "\"\n") (def source (slurp fname)) diff --git a/src/boot/buffer_test.c b/src/boot/buffer_test.c index 0698e3c9..03800f45 100644 --- a/src/boot/buffer_test.c +++ b/src/boot/buffer_test.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/boot/number_test.c b/src/boot/number_test.c index 15bd085f..dbcb07b9 100644 --- a/src/boot/number_test.c +++ b/src/boot/number_test.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -44,7 +44,9 @@ static void test_valid_str(const char *str) { } int number_test() { - +#ifdef JANET_PLAN9 + return 0; +#endif test_valid_str("1.0"); test_valid_str("1"); test_valid_str("2.1"); diff --git a/src/boot/system_test.c b/src/boot/system_test.c index 4fcd4c66..13e2edef 100644 --- a/src/boot/system_test.c +++ b/src/boot/system_test.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -37,7 +37,7 @@ int system_test() { /* Check the version defines are self consistent */ char version_combined[256]; - sprintf(version_combined, "%d.%d.%d%s", JANET_VERSION_MAJOR, JANET_VERSION_MINOR, JANET_VERSION_PATCH, JANET_VERSION_EXTRA); + 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 */ @@ -51,6 +51,10 @@ int system_test() { 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)); diff --git a/src/boot/table_test.c b/src/boot/table_test.c index 1b07a577..761702f6 100644 --- a/src/boot/table_test.c +++ b/src/boot/table_test.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/conf/janetconf.h b/src/conf/janetconf.h index 66c7284f..618a4c2c 100644 --- a/src/conf/janetconf.h +++ b/src/conf/janetconf.h @@ -4,10 +4,10 @@ #define JANETCONF_H #define JANET_VERSION_MAJOR 1 -#define JANET_VERSION_MINOR 40 -#define JANET_VERSION_PATCH 0 -#define JANET_VERSION_EXTRA "" -#define JANET_VERSION "1.40.0" +#define JANET_VERSION_MINOR 41 +#define JANET_VERSION_PATCH 3 +#define JANET_VERSION_EXTRA "-dev" +#define JANET_VERSION "1.41.3-dev" /* #define JANET_BUILD "local" */ @@ -16,6 +16,7 @@ /* #define JANET_THREAD_LOCAL _Thread_local */ /* #define JANET_NO_DYNAMIC_MODULES */ /* #define JANET_NO_NANBOX */ +/* #define JANET_NANBOX_64_POINTER_SHIFT 0 */ /* #define JANET_API __attribute__((visibility ("default"))) */ /* These settings should be specified before amalgamation is diff --git a/src/core/abstract.c b/src/core/abstract.c index dab8536d..bfbf98af 100644 --- a/src/core/abstract.c +++ b/src/core/abstract.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -37,7 +37,7 @@ /* Create new userdata */ void *janet_abstract_begin(const JanetAbstractType *atype, size_t size) { JanetAbstractHead *header = janet_gcalloc(JANET_MEMORY_NONE, - sizeof(JanetAbstractHead) + size); + sizeof(JanetAbstractHead) + size); header->size = size; header->type = atype; return (void *) & (header->data); @@ -201,4 +201,17 @@ 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 diff --git a/src/core/array.c b/src/core/array.c index bda15159..43bec654 100644 --- a/src/core/array.c +++ b/src/core/array.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/core/asm.c b/src/core/asm.c index 4f54623a..a563d633 100644 --- a/src/core/asm.c +++ b/src/core/asm.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -567,6 +567,13 @@ static JanetAssembleResult janet_asm1(JanetAssembler *parent, Janet source, int 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); @@ -982,6 +989,14 @@ 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++) { @@ -1032,6 +1047,7 @@ Janet janet_disasm(JanetFuncDef *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)); @@ -1048,6 +1064,7 @@ JANET_CORE_FN(cfun_asm, "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); @@ -1067,6 +1084,8 @@ JANET_CORE_FN(cfun_disasm, "* :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" @@ -1076,6 +1095,7 @@ JANET_CORE_FN(cfun_disasm, "* :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) { @@ -1088,7 +1108,9 @@ JANET_CORE_FN(cfun_disasm, 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, "symbolmap")) return janet_disasm_symbolslots(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); diff --git a/src/core/buffer.c b/src/core/buffer.c index 06e3f9f9..e8c1e85b 100644 --- a/src/core/buffer.c +++ b/src/core/buffer.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -74,6 +74,7 @@ JanetBuffer *janet_pointer_buffer_unsafe(void *memory, int32_t capacity, int32_t void janet_buffer_deinit(JanetBuffer *buffer) { if (!(buffer->gc.flags & JANET_BUFFER_FLAG_NO_REALLOC)) { janet_free(buffer->data); + buffer->data = NULL; } } @@ -271,8 +272,8 @@ JANET_CORE_FN(cfun_buffer_trim, 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.") { + "Append bytes to a buffer. Returns the modified buffer. " + "Expands the buffer as necessary. Throws an error if size limit is exceeded.") { int32_t i; janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); @@ -285,8 +286,8 @@ JANET_CORE_FN(cfun_buffer_u8, 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.") { + "in twos complement, little endian order, unsigned for all x. Returns the modified buffer. " + "Expands the buffer as necessary. Throws an error if size limit is exceeded.") { int32_t i; janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); @@ -305,7 +306,7 @@ JANET_CORE_FN(cfun_buffer_chars, "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.") { + "Expands the buffer as necessary. Throws an error if size limit is exceeded.") { int32_t i; janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); @@ -367,7 +368,8 @@ static void reverse_u64(uint8_t bytes[8]) { 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.") { + "Returns the modified buffer." + "Expands the buffer as necessary. Throws an error if size limit is exceeded.") { janet_fixarity(argc, 3); JanetBuffer *buffer = janet_getbuffer(argv, 0); int reverse = should_reverse_bytes(argv, 1); @@ -386,7 +388,8 @@ JANET_CORE_FN(cfun_buffer_push_uint16, 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.") { + "Returns the modified buffer." + "Expands the buffer as necessary. Throws an error if size limit is exceeded.") { janet_fixarity(argc, 3); JanetBuffer *buffer = janet_getbuffer(argv, 0); int reverse = should_reverse_bytes(argv, 1); @@ -402,7 +405,8 @@ JANET_CORE_FN(cfun_buffer_push_uint32, 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.") { + "Returns the modified buffer." + "Expands the buffer as necessary. Throws an error if size limit is exceeded.") { janet_fixarity(argc, 3); JanetBuffer *buffer = janet_getbuffer(argv, 0); int reverse = should_reverse_bytes(argv, 1); @@ -418,7 +422,8 @@ JANET_CORE_FN(cfun_buffer_push_uint64, 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.") { + "Returns the modified buffer." + "Expands the buffer as necessary. Throws an error if size limit is exceeded.") { janet_fixarity(argc, 3); JanetBuffer *buffer = janet_getbuffer(argv, 0); int reverse = should_reverse_bytes(argv, 1); @@ -434,7 +439,8 @@ JANET_CORE_FN(cfun_buffer_push_float32, 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.") { + "Returns the modified buffer." + "Expands the buffer as necessary. Throws an error if size limit is exceeded.") { janet_fixarity(argc, 3); JanetBuffer *buffer = janet_getbuffer(argv, 0); int reverse = should_reverse_bytes(argv, 1); @@ -487,7 +493,7 @@ JANET_CORE_FN(cfun_buffer_push, "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.") { + "Expands the buffer as necessary. Throws an error if size limit is exceeded.") { janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_getbuffer(argv, 0); buffer_push_impl(buffer, argv, 1, argc); diff --git a/src/core/bytecode.c b/src/core/bytecode.c index 7f1acdac..8424efd6 100644 --- a/src/core/bytecode.c +++ b/src/core/bytecode.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -29,7 +29,7 @@ #endif /* Look up table for instructions */ -enum JanetInstructionType janet_instructions[JOP_INSTRUCTION_COUNT] = { +const enum JanetInstructionType janet_instructions[JOP_INSTRUCTION_COUNT] = { JINT_0, /* JOP_NOOP, */ JINT_S, /* JOP_ERROR, */ JINT_ST, /* JOP_TYPECHECK, */ @@ -139,6 +139,8 @@ void janet_bytecode_remove_noops(JanetFuncDef *def) { case JOP_JUMP: /* relative pc is in DS field of instruction */ old_jump_target = i + (((int32_t)instr) >> 8); + janet_assert(old_jump_target >= 0, "bounds"); + janet_assert(old_jump_target < def->bytecode_length, "bounds"); new_jump_target = pc_map[old_jump_target]; instr += (uint32_t)(new_jump_target - old_jump_target + (i - j)) << 8; break; @@ -148,6 +150,8 @@ void janet_bytecode_remove_noops(JanetFuncDef *def) { case JOP_JUMP_IF_NOT_NIL: /* relative pc is in ES field of instruction */ old_jump_target = i + (((int32_t)instr) >> 16); + janet_assert(old_jump_target >= 0, "bounds"); + janet_assert(old_jump_target < def->bytecode_length, "bounds"); new_jump_target = pc_map[old_jump_target]; instr += (uint32_t)(new_jump_target - old_jump_target + (i - j)) << 16; break; @@ -496,6 +500,30 @@ int janet_verify(JanetFuncDef *def) { } } + /* Verify debug info - slotmapping, etc. */ + for (int32_t i = def->symbolmap_length - 1; i >= 0; i--) { + JanetSymbolMap jsm = def->symbolmap[i]; + if (jsm.birth_pc == UINT32_MAX) { + if (jsm.death_pc >= (uint32_t) def->environments_length) { + return 10; + /* We should also check jsm.slot_index */ + } + } else { + if (jsm.slot_index >= (uint32_t) def->slotcount) { + return 11; + } + if (jsm.birth_pc != UINT32_MAX && jsm.birth_pc >= (uint32_t) def->bytecode_length) { + return 12; + } + if (jsm.death_pc != UINT32_MAX && jsm.death_pc > (uint32_t) def->bytecode_length) { + return 13; + } + } + if (jsm.symbol == NULL) { + return 14; + } + } + return 0; } @@ -522,6 +550,7 @@ JanetFuncDef *janet_funcdef_alloc(void) { def->bytecode_length = 0; def->environments_length = 0; def->symbolmap_length = 0; + def->named_args_count = 0; return def; } diff --git a/src/core/capi.c b/src/core/capi.c index acee70ce..d2b91116 100644 --- a/src/core/capi.c +++ b/src/core/capi.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -50,11 +50,18 @@ JANET_NO_RETURN static void janet_top_level_signal(const char *msg) { JANET_TOP_LEVEL_SIGNAL(msg); #else fputs(msg, stdout); + if (!(janet_vm.sandbox_flags & JANET_SANDBOX_EXIT)) { + /* Exit is not forbidden */ + exit(EXIT_FAILURE); + } + /* If not able to signal, then select good default behavior - for single threaded programs, we have no + * choice but to exit. */ # ifdef JANET_SINGLE_THREADED - exit(-1); + exit(EXIT_FAILURE); # elif defined(JANET_WINDOWS) ExitThread(-1); # else + /* Other threads will continue as usual */ pthread_exit(NULL); # endif #endif @@ -339,6 +346,21 @@ uint16_t janet_getuinteger16(const Janet *argv, int32_t n) { return (uint16_t) janet_unwrap_number(x); } +int8_t janet_getinteger8(const Janet *argv, int32_t n) { + Janet x = argv[n]; + if (!janet_checkint8(x)) { + janet_panicf("bad slot #%d, expected 8 bit signed integer, got %v", n, x); + } + return (int16_t) janet_unwrap_number(x); +} + +uint8_t janet_getuinteger8(const Janet *argv, int32_t n) { + Janet x = argv[n]; + if (!janet_checkuint8(x)) { + janet_panicf("bad slot #%d, expected 8 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 @@ -460,7 +482,7 @@ Janet janet_dyn(const char *name) { return janet_table_get(janet_vm.top_dyns, janet_ckeywordv(name)); } if (janet_vm.fiber->env) { - return janet_table_get(janet_vm.fiber->env, janet_ckeywordv(name)); + return janet_table_get_keyword(janet_vm.fiber->env, name); } else { return janet_wrap_nil(); } @@ -557,6 +579,18 @@ void *janet_optabstract(const Janet *argv, int32_t argc, int32_t n, const JanetA 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) { @@ -564,6 +598,8 @@ JanetAtomicInt janet_atomic_inc(JanetAtomicInt volatile *x) { 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 @@ -574,6 +610,8 @@ JanetAtomicInt janet_atomic_dec(JanetAtomicInt volatile *x) { 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 @@ -582,6 +620,8 @@ JanetAtomicInt janet_atomic_dec(JanetAtomicInt volatile *x) { 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 @@ -592,6 +632,8 @@ JanetAtomicInt janet_atomic_load(JanetAtomicInt volatile *x) { 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 diff --git a/src/core/cfuns.c b/src/core/cfuns.c index 960bd502..571b3622 100644 --- a/src/core/cfuns.c +++ b/src/core/cfuns.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -188,7 +188,7 @@ static JanetSlot do_get(JanetFopts opts, JanetSlot *args) { 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; + c->buffer[label] |= (uint32_t)(current - label) << 16; return t; } else { return opreduce(opts, args, JOP_GET, 0, janet_wrap_nil(), janet_wrap_nil()); @@ -201,14 +201,29 @@ 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) { - 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()); + 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 { - 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; + /* 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) { @@ -330,7 +345,7 @@ static JanetSlot compreduce( 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); + c->buffer[label] |= ((uint32_t)(end - label) << 16); } janet_v_free(labels); return t; diff --git a/src/core/compile.c b/src/core/compile.c index ea81a660..cee11a52 100644 --- a/src/core/compile.c +++ b/src/core/compile.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -91,13 +91,38 @@ void janetc_freeslot(JanetCompiler *c, JanetSlot s) { } /* 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) { +void janetc_nameslot(JanetCompiler *c, const uint8_t *sym, JanetSlot s, uint32_t flags) { + if (!(flags & JANET_DEFFLAG_NO_SHADOWCHECK)) { + if (sym[0] != '_') { + switch (janetc_shadowcheck(c, sym)) { + default: + break; + case JANETC_SHADOW_MACRO: + janetc_lintf(c, JANET_C_LINT_NORMAL, "binding %q is shadowing a macro", janet_wrap_symbol(sym)); + break; + case JANETC_SHADOW_LOCAL_HIDES_LOCAL: + janetc_lintf(c, JANET_C_LINT_STRICT, "binding %q is shadowing a binding", janet_wrap_symbol(sym)); + break; + case JANETC_SHADOW_LOCAL_HIDES_GLOBAL: + janetc_lintf(c, JANET_C_LINT_STRICT, "binding %q is shadowing a top-level binding", janet_wrap_symbol(sym)); + break; + case JANETC_SHADOW_GLOBAL_HIDES_GLOBAL: + janetc_lintf(c, JANET_C_LINT_STRICT, "top-level binding %q is shadowing another top-level binding", janet_wrap_symbol(sym)); + break; + } + } + } SymPair sp; int32_t cnt = janet_v_count(c->buffer); sp.sym = sym; sp.sym2 = sym; sp.slot = s; sp.keep = 0; + if (flags & JANET_DEFFLAG_NO_UNUSED) { + sp.referenced = 1; + } else { + sp.referenced = sym[0] == '_'; /* Fake ref if symbol starts with _ to avoid lints */ + } sp.slot.flags |= JANET_SLOT_NAMED; sp.birth_pc = cnt ? cnt - 1 : 0; sp.death_pc = UINT32_MAX; @@ -170,6 +195,10 @@ void janetc_popscope(JanetCompiler *c) { /* 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) { @@ -240,6 +269,42 @@ static int lookup_missing( return 1; } +/* Check if a binding is defined in an upper scope. This lets us check for + * variable shadowing. */ +Shadowing janetc_shadowcheck(JanetCompiler *c, const uint8_t *sym) { + /* Check locals */ + JanetScope *scope = c->scope; + int is_global = (scope->flags & JANET_SCOPE_TOP); + while (scope) { + int32_t len = janet_v_count(scope->syms); + for (int32_t i = len - 1; i >= 0; i--) { + SymPair *pair = scope->syms + i; + if (pair->sym == sym) { + if (is_global) { + /* This can happen in a top level form like (def [x [x y]] [1 [2 3]])` where a symbol is reused in one expression */ + /* janet_assert(!is_global, "shadowing analysis is incorrect. compiler bug"); */ + return JANETC_SHADOW_GLOBAL_HIDES_GLOBAL; + } + return JANETC_SHADOW_LOCAL_HIDES_LOCAL; + } + } + scope = scope->parent; + } + /* Check globals */ + JanetBinding binding = janet_resolve_ext(c->env, sym); + if (binding.type == JANET_BINDING_MACRO || binding.type == JANET_BINDING_DYNAMIC_MACRO) { + return JANETC_SHADOW_MACRO; + } else if (binding.type == JANET_BINDING_NONE) { + return JANETC_SHADOW_NONE; + } else { + if (is_global) { + return JANETC_SHADOW_GLOBAL_HIDES_GLOBAL; + } else { + return JANETC_SHADOW_LOCAL_HIDES_GLOBAL; + } + } +} + /* Allow searching for symbols. Return information about the symbol */ JanetSlot janetc_resolve( JanetCompiler *c, @@ -262,6 +327,7 @@ JanetSlot janetc_resolve( pair = scope->syms + i; if (pair->sym == sym) { ret = pair->slot; + pair->referenced = 1; goto found; } } @@ -274,7 +340,7 @@ JanetSlot janetc_resolve( { JanetBinding binding = janet_resolve_ext(c->env, sym); if (binding.type == JANET_BINDING_NONE) { - Janet handler = janet_table_get(c->env, janet_ckeywordv("missing-symbol")); + Janet handler = janet_table_get_keyword(c->env, "missing-symbol"); switch (janet_type(handler)) { case JANET_NIL: break; @@ -346,6 +412,7 @@ found: /* 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"); @@ -437,11 +504,22 @@ JanetSlot *janetc_toslotskv(JanetCompiler *c, Janet ds) { const JanetKV *kvs = NULL; int32_t cap = 0, len = 0; janet_dictionary_view(ds, &kvs, &len, &cap); - for (int32_t i = 0; i < cap; i++) { - if (janet_checktype(kvs[i].key, JANET_NIL)) continue; - janet_v_push(ret, janetc_value(subopts, kvs[i].key)); - janet_v_push(ret, janetc_value(subopts, kvs[i].value)); + /* 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; } @@ -514,9 +592,9 @@ void janetc_throwaway(JanetFopts opts, Janet x) { 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, "unusued"); + janetc_scope(&unusedScope, c, JANET_SCOPE_UNUSED, "unused"); janetc_value(opts, x); - janetc_lintf(c, JANET_C_LINT_STRICT, "dead code, consider removing %.2q", 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; @@ -526,7 +604,7 @@ void janetc_throwaway(JanetFopts opts, Janet x) { } /* Compile a call or tailcall instruction */ -static JanetSlot janetc_call(JanetFopts opts, JanetSlot *slots, JanetSlot fun) { +static JanetSlot janetc_call(JanetFopts opts, JanetSlot *slots, JanetSlot fun, const Janet *form) { JanetSlot retslot; JanetCompiler *c = opts.compiler; int specialized = 0; @@ -552,6 +630,8 @@ static JanetSlot janetc_call(JanetFopts opts, JanetSlot *slots, JanetSlot fun) { 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; @@ -575,6 +655,47 @@ static JanetSlot janetc_call(JanetFopts opts, JanetSlot *slots, JanetSlot fun) { 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; @@ -809,14 +930,16 @@ JanetSlot janetc_value(JanetFopts opts, Janet x) { } 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); + 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; @@ -856,19 +979,21 @@ 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->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->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; @@ -939,8 +1064,9 @@ JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c) { 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) chunks[7] &= 0xFFFFU; + if (scope->ua.count > 7 && slotchunks > 7) chunks[7] &= 0xFFFFU; def->closure_bitset = chunks; } @@ -960,7 +1086,7 @@ JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c) { if (pair.sym2) { JanetSymbolMap jsm; jsm.birth_pc = UINT32_MAX; - jsm.death_pc = j; + jsm.death_pc = j; /* Use death_pc to encode environment index */ jsm.slot_index = pair.slot.index; jsm.symbol = pair.sym2; janet_v_push(locals, jsm); @@ -974,6 +1100,10 @@ JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c) { 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 { @@ -1018,6 +1148,7 @@ static void janetc_init(JanetCompiler *c, JanetTable *env, const uint8_t *where, c->current_mapping.line = -1; c->current_mapping.column = -1; c->lints = lints; + c->is_redef = janet_truthy(janet_table_get_keyword(c->env, "redef")); /* Init result */ c->result.error = NULL; c->result.status = JANET_COMPILE_OK; @@ -1082,6 +1213,7 @@ JANET_CORE_FN(cfun_compile, "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; diff --git a/src/core/compile.h b/src/core/compile.h index 197f034c..60f698b3 100644 --- a/src/core/compile.h +++ b/src/core/compile.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -36,6 +36,15 @@ typedef enum { JANET_C_LINT_STRICT } JanetCompileLintLevel; +/* Kinds of variable shadowing for linting */ +typedef enum { + JANETC_SHADOW_NONE, + JANETC_SHADOW_MACRO, + JANETC_SHADOW_GLOBAL_HIDES_GLOBAL, + JANETC_SHADOW_LOCAL_HIDES_GLOBAL, + JANETC_SHADOW_LOCAL_HIDES_LOCAL +} Shadowing; + /* Tags for some functions for the prepared inliner */ #define JANET_FUN_DEBUG 1 #define JANET_FUN_ERROR 2 @@ -114,6 +123,7 @@ typedef struct SymPair { 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; @@ -183,6 +193,9 @@ struct JanetCompiler { /* Collect linting results */ JanetArray *lints; + + /* Cached version of (dyn *redef*) */ + int is_redef; }; #define JANET_FOPTS_TAIL 0x10000 @@ -220,8 +233,11 @@ const JanetFunOptimizer *janetc_funopt(uint32_t flags); /* Get a special. Return NULL if none exists */ const JanetSpecial *janetc_special(const uint8_t *name); +#define JANET_DEFFLAG_NO_SHADOWCHECK 1 +#define JANET_DEFFLAG_NO_UNUSED 2 + void janetc_freeslot(JanetCompiler *c, JanetSlot s); -void janetc_nameslot(JanetCompiler *c, const uint8_t *sym, JanetSlot s); +void janetc_nameslot(JanetCompiler *c, const uint8_t *sym, JanetSlot s, uint32_t flags); JanetSlot janetc_farslot(JanetCompiler *c); /* Throw away some code after checking that it is well formed. */ @@ -265,12 +281,15 @@ JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c); /* Create a destroy slot */ JanetSlot janetc_cslot(Janet x); -/* Search for a symbol */ +/* Search for a symbol, and mark any found symbols as "used" for dead code elimination and linting */ JanetSlot janetc_resolve(JanetCompiler *c, const uint8_t *sym); /* Load the system dialect IR */ void janet_lib_sysir(JanetTable *env); +/* Check if a symbol is already in scope for shadowing lints */ +Shadowing janetc_shadowcheck(JanetCompiler *c, const uint8_t *sym); + /* Bytecode optimization */ void janet_bytecode_movopt(JanetFuncDef *def); void janet_bytecode_remove_noops(JanetFuncDef *def); diff --git a/src/core/corelib.c b/src/core/corelib.c index 4f2b5237..3f3ea57b 100644 --- a/src/core/corelib.c +++ b/src/core/corelib.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -27,6 +27,7 @@ #include "compile.h" #include "state.h" #include "util.h" +#include "fiber.h" #endif /* Generated bytes */ @@ -69,7 +70,7 @@ JanetModule janet_native(const char *name, const uint8_t **error) { 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)", + snprintf(errbuf, sizeof(errbuf), "config mismatch - host %d.%.d.%d(%.4x) vs. module %d.%d.%d(%.4x) - native needs to be recompiled!", host.major, host.minor, host.patch, @@ -294,6 +295,7 @@ JANET_CORE_FN(janet_core_native, "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; @@ -306,17 +308,19 @@ JANET_CORE_FN(janet_core_native, 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"), argv[0]); + 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.") { + "Returns a string that is a human-readable description of " + "`x`. For indexed, dictionary, fiber, pointer, and some " + "abstract types, 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]); @@ -437,28 +441,33 @@ JANET_CORE_FN(janet_core_range, 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); + count = (step > 0.0) ? (stop - start) / step : + ((step < 0.0) ? (stop - start) / step : 0.0); } else if (argc == 2) { - start = janet_getnumber(argv, 0); - stop = janet_getnumber(argv, 1); + start = janet_getnumber(argv, 0.0); + stop = janet_getnumber(argv, 1.0); count = stop - start; } else { - stop = janet_getnumber(argv, 0); + stop = janet_getnumber(argv, 0.0); count = stop; } - count = (count > 0) ? count : 0; + if (isinf(step)) { + janet_panic("infinite step not allowed"); + } + count = (count > 0.0) ? count : 0.0; int32_t int_count; - janet_assert(count >= 0, "bad range code"); + janet_assert(count >= 0.0, "bad range code (count)"); 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"); + if (int_count) { /* e.g. (range 10 0 0) */ + if (step > 0.0) { + janet_assert(start + int_count * step >= stop, "bad range code (+step)"); + } else { + janet_assert(start + int_count * step <= stop, "bad range code (-step)"); + } } JanetArray *array = janet_array(int_count); for (int32_t i = 0; i < int_count; i++) { @@ -568,20 +577,21 @@ JANET_CORE_FN(janet_core_gcinterval, 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" + "* :number\n" + "* :nil\n" + "* :boolean\n" + "* :fiber\n" + "* :string\n" + "* :symbol\n" + "* :keyword\n" + "* :array\n" + "* :tuple\n" + "* :table\n" + "* :struct\n" + "* :buffer\n" + "* :function\n" + "* :cfunction\n" + "* :pointer\n\n" "or another keyword for an abstract type.") { janet_fixarity(argc, 1); JanetType t = janet_type(argv[0]); @@ -746,8 +756,11 @@ typedef struct 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}, + {"exit", JANET_SANDBOX_EXIT}, {"ffi", JANET_SANDBOX_FFI}, {"ffi-define", JANET_SANDBOX_FFI_DEFINE}, {"ffi-jit", JANET_SANDBOX_FFI_JIT}, @@ -764,6 +777,8 @@ static const SandboxOption sandbox_options[] = { {"sandbox", JANET_SANDBOX_SANDBOX}, {"signal", JANET_SANDBOX_SIGNAL}, {"subprocess", JANET_SANDBOX_SUBPROCESS}, + {"threads", JANET_SANDBOX_THREADS}, + {"unmarshal", JANET_SANDBOX_UNMARSHAL}, {NULL, 0} }; @@ -772,8 +787,11 @@ JANET_CORE_FN(janet_core_sandbox, "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" + "* :exit - disallow calling `os/exit` or otherwise early exiting the process in trivial ways.\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" @@ -789,7 +807,9 @@ JANET_CORE_FN(janet_core_sandbox, "* :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") { + "* :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); @@ -997,11 +1017,11 @@ static void make_apply(JanetTable *env) { 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.")); + "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[] = { @@ -1154,82 +1174,104 @@ JanetTable *janet_core_env(JanetTable *replacements) { 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.")); + "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.")); + JDOC("(next x &opt key)\n\n" + "Gets the next key in `x`. Can be used to iterate through " + "the keys of `x` in an unspecified order. Keys are guaranteed " + "to be seen only once per iteration if `x` is not mutated " + "during iteration. If `key` is `nil`, returns the first key. " + "If `nil` is returned, there are no more keys to iterate " + "through.\n" + "\n" + "`x` can be a bytes, indexed, dictionary, fiber, or abstract " + "type with a suitable `next` method.")); 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.")); + "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.")); + "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.")); + "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.")); + "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.")); + "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.")); + "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.")); + JDOC("(in x key &opt dflt)\n\n" + "Get value in `x` at `key`. For bytes and indexed " + "types, `key` must be a non-negative interger in " + "bounds or an error is raised. For dictionaries " + "`key` must be a non-nil value and if not found, " + "will return `dflt` if provided or `nil` otherwise.\n" + "\n" + "`x` can be a bytes, indexed, dictionary, fiber, or " + "abstract type with a suitable `get` method.")); 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.")); + JDOC("(get x key &opt dflt)\n\n" + "Get the value mapped to `key` in `x`. Returns `dflt` " + "or `nil` if `key` is not found. Similar to `in`, but " + "will not throw an error if `key` is invalid for `x`. " + "However, if `x` is an abstract type, its getter may " + "throw an error.\n" + "\n" + "`x` can be a bytes, indexed, dictionary, fiber, or " + "abstract type with a suitable `get` method.")); 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.")); + JDOC("(put x key val)\n\n" + "Associate `key` with `val` for mutable `x`. Arrays " + "and buffers only accept non-negative integer keys, " + "and will expand if an out of bounds value is " + "provided. For an array, extra space will be filled " + "with `nil`s, while for buffers, 0 bytes are used " + "instead. For a table, putting a key that is in the " + "table prototype will hide the association defined by " + "the prototype, but will not mutate the prototype " + "table. Putting a `nil` value into a table will " + "remove the table's corresponding association. " + "Returns `x`.")); 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.")); + JDOC("(length x)\n\n" + "Returns the length or count of `x` as an integer. " + "Returns are guaranteed to be in constant time " + "except for abstract types. For dictionaries, " + "returns the number of key-value pairs.\n" + "\n" + "`x` can be a bytes, indexed, dictionary, or " + "abstract type with a suitable `length` method.")); 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.")); @@ -1238,74 +1280,74 @@ JanetTable *janet_core_env(JanetTable *replacements) { /* Variadic ops */ templatize_varop(env, JANET_FUN_ADD, "+", 0, 0, JOP_ADD, JDOC("(+ & xs)\n\n" - "Returns the sum of all xs. xs must be integers or real numbers only. If xs is empty, return 0.")); + "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.")); + "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.")); + "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.")); + "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.")); + "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`.")); + "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.")); + "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.")); + "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.")); + "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 in xs must be an integer.")); + "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.")); + "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.")); + "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.")); + "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.")); + "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.")); + "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.")); + "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.")); + "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.")); + "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.")); + "Check if any values in xs are not equal. Returns a boolean.")); /* Platform detection */ janet_def(env, "janet/version", janet_cstringv(JANET_VERSION), @@ -1314,7 +1356,7 @@ JanetTable *janet_core_env(JanetTable *replacements) { 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.")); + "if native modules are compatible with the host program.")); /* Allow references to the environment */ janet_def(env, "root-env", janet_wrap_table(env), @@ -1354,12 +1396,16 @@ JanetTable *janet_core_env(JanetTable *replacements) { lidv = midv = janet_wrap_nil(); janet_resolve(env, janet_csymbol("load-image-dict"), &lidv); janet_resolve(env, janet_csymbol("make-image-dict"), &midv); - 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); + + /* 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); + } } } diff --git a/src/core/debug.c b/src/core/debug.c index 6e03f78d..6c39dfe8 100644 --- a/src/core/debug.c +++ b/src/core/debug.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -343,14 +343,25 @@ static Janet doframe(JanetStackFrame *frame) { 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]; + /* death_pc has secondary meaning here, we use it to encode the environment index */ + if (jsm.death_pc < (uint32_t) def->environments_length) { + /* death_pc is in valid range */ + JanetFuncEnv *env = frame->func->envs[jsm.death_pc]; + if (jsm.slot_index < (uint32_t) env->length) { + /* slot_index range good */ + if (env->offset > 0) { + /* On stack */ + value = env->as.fiber->data[env->offset + jsm.slot_index]; + } else { + /* Off stack */ + value = env->as.values[jsm.slot_index]; + } + } } } else if (pc >= jsm.birth_pc && pc < jsm.death_pc) { - value = stack[jsm.slot_index]; + if (jsm.slot_index < (uint32_t) def->slotcount) { + value = stack[jsm.slot_index]; + } } janet_table_put(local_bindings, janet_wrap_symbol(jsm.symbol), value); } @@ -411,8 +422,10 @@ JANET_CORE_FN(cfun_debug_argstack, 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; + if (array->capacity) { + memcpy(array->data, fiber->data + fiber->stackstart, array->capacity * sizeof(Janet)); + array->count = array->capacity; + } return janet_wrap_array(array); } diff --git a/src/core/emit.c b/src/core/emit.c index 47127800..32e20fc9 100644 --- a/src/core/emit.c +++ b/src/core/emit.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -78,10 +78,10 @@ static int32_t janetc_const(JanetCompiler *c, Janet x) { 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); + janetc_emit(c, ((uint32_t) reg << 8) | JOP_LOAD_NIL); break; case JANET_BOOLEAN: - janetc_emit(c, (reg << 8) | + janetc_emit(c, ((uint32_t) reg << 8) | (janet_unwrap_boolean(k) ? JOP_LOAD_TRUE : JOP_LOAD_FALSE)); break; case JANET_NUMBER: { @@ -93,8 +93,8 @@ static void janetc_loadconst(JanetCompiler *c, Janet k, int32_t reg) { goto do_constant; uint32_t iu = (uint32_t)i; janetc_emit(c, - (iu << 16) | - (reg << 8) | + ((uint32_t) iu << 16) | + ((uint32_t) reg << 8) | JOP_LOAD_INTEGER); break; } @@ -102,8 +102,8 @@ static void janetc_loadconst(JanetCompiler *c, Janet k, int32_t reg) { do_constant: { int32_t cindex = janetc_const(c, k); janetc_emit(c, - (cindex << 16) | - (reg << 8) | + ((uint32_t) cindex << 16) | + ((uint32_t) reg << 8) | JOP_LOAD_CONSTANT); break; } @@ -114,13 +114,14 @@ static void janetc_loadconst(JanetCompiler *c, Janet k, int32_t reg) { static void janetc_movenear(JanetCompiler *c, int32_t dest, JanetSlot src) { + janet_assert(dest <= 255, "dest slot index must be <= 255"); 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) | + ((uint32_t) dest << 16) | + ((uint32_t) dest << 8) | JOP_GET_INDEX); } } else if (src.envindex >= 0) { @@ -138,7 +139,7 @@ static void janetc_movenear(JanetCompiler *c, } } -/* Move a near register to a Slot. */ +/* Move a near or far register to a Slot. */ static void janetc_moveback(JanetCompiler *c, JanetSlot dest, int32_t src) { @@ -146,11 +147,17 @@ static void janetc_moveback(JanetCompiler *c, 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) | + ((uint32_t) src << 16) | + ((uint32_t) refreg << 8) | JOP_PUT_INDEX); janetc_regalloc_freetemp(&c->scope->ra, refreg, JANETC_REGTEMP_5); } else if (dest.envindex >= 0) { + /* Convert src to near reg */ + if (src > 255) { + int32_t newsrc = JANETC_REGTEMP_5 + 0xF0; + janetc_emit(c, JOP_MOVE_NEAR | ((uint32_t)(src) << 16) | ((uint32_t) newsrc << 8)); + src = newsrc; + } janetc_emit(c, ((uint32_t)(dest.index) << 24) | ((uint32_t)(dest.envindex) << 16) | @@ -158,6 +165,12 @@ static void janetc_moveback(JanetCompiler *c, JOP_SET_UPVALUE); } else if (dest.index != src) { janet_assert(dest.index >= 0, "bad slot"); + /* Convert src to near reg */ + if (src > 255) { + int32_t newsrc = JANETC_REGTEMP_5 + 0xF0; + janetc_emit(c, JOP_MOVE_NEAR | ((uint32_t)(src) << 16) | ((uint32_t)newsrc << 8)); + src = newsrc; + } janetc_emit(c, ((uint32_t)(dest.index) << 16) | ((uint32_t)(src) << 8) | @@ -186,7 +199,7 @@ static int32_t janetc_regfar(JanetCompiler *c, JanetSlot s, JanetcRegisterTemp t janetc_movenear(c, nearreg, s); if (nearreg >= 0xF0) { reg = janetc_allocfar(c); - janetc_emit(c, JOP_MOVE_FAR | (nearreg << 8) | (reg << 16)); + janetc_emit(c, JOP_MOVE_FAR | ((uint32_t) nearreg << 8) | ((uint32_t) reg << 16)); janetc_regalloc_freetemp(&c->scope->ra, nearreg, tag); } else { reg = nearreg; @@ -255,7 +268,7 @@ void janetc_copy( 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)); + janetc_emit(c, op | ((uint32_t) reg << 8) | ((uint32_t) rest << 16)); if (wr) janetc_moveback(c, s, reg); janetc_free_regnear(c, s, reg, JANETC_REGTEMP_0); @@ -265,7 +278,7 @@ static int32_t emit1s(JanetCompiler *c, uint8_t op, JanetSlot s, int32_t rest, i 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)); + janetc_emit(c, op | ((uint32_t) reg << 8)); if (wr) janetc_moveback(c, s, reg); janetc_free_regnear(c, s, reg, JANETC_REGTEMP_0); @@ -297,7 +310,7 @@ static int32_t emit2s(JanetCompiler *c, uint8_t op, JanetSlot s1, JanetSlot s2, 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_emit(c, op | ((uint32_t) reg1 << 8) | ((uint32_t) reg2 << 16) | ((uint32_t)rest << 24)); janetc_free_regnear(c, s2, reg2, JANETC_REGTEMP_1); if (wr) janetc_moveback(c, s1, reg1); @@ -309,7 +322,7 @@ int32_t janetc_emit_ss(JanetCompiler *c, uint8_t op, JanetSlot s1, JanetSlot s2, 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_emit(c, op | ((uint32_t) reg1 << 8) | ((uint32_t) reg2 << 16)); janetc_free_regnear(c, s2, reg2, JANETC_REGTEMP_1); if (wr) janetc_moveback(c, s1, reg1); @@ -330,7 +343,7 @@ int32_t janetc_emit_sss(JanetCompiler *c, uint8_t op, JanetSlot s1, JanetSlot s2 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_emit(c, op | ((uint32_t) reg1 << 8) | ((uint32_t) 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) diff --git a/src/core/emit.h b/src/core/emit.h index 64a6a268..4e343198 100644 --- a/src/core/emit.h +++ b/src/core/emit.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/core/ev.c b/src/core/ev.c index 5e2b1044..1971d7bf 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -326,6 +326,9 @@ static void janet_stream_checktoclose(JanetStream *stream) { /* Forward declaration */ static void janet_register_stream(JanetStream *stream); +#ifndef JANET_WINDOWS +static void janet_unregister_stream(JanetStream *stream); +#endif static const JanetMethod ev_default_stream_methods[] = { {"close", janet_cfun_stream_close}, @@ -357,6 +360,8 @@ JanetStream *janet_stream(JanetHandle handle, uint32_t flags, const JanetMethod static void janet_stream_close_impl(JanetStream *stream) { stream->flags |= JANET_STREAM_CLOSED; int canclose = !(stream->flags & JANET_STREAM_NOT_CLOSEABLE); + /* If we are positive that the stream is the last instance of the underlying file description (such that "dup" was never called on the file description) + * then skip unregister to save a syscall */ #ifdef JANET_WINDOWS if (stream->handle != INVALID_HANDLE_VALUE) { #ifdef JANET_NET @@ -370,19 +375,11 @@ static void janet_stream_close_impl(JanetStream *stream) { stream->handle = INVALID_HANDLE_VALUE; } #else + int canunregister = !(stream->flags & JANET_STREAM_UNREGISTERED); if (stream->handle != -1) { + if (canunregister) janet_unregister_stream(stream); 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 } @@ -433,9 +430,10 @@ static int janet_stream_getter(void *p, Janet key, Janet *out) { static void janet_stream_marshal(void *p, JanetMarshalContext *ctx) { JanetStream *s = p; - if (!(ctx->flags & JANET_MARSHAL_UNSAFE)) { + if (!(janet_marshal_flags(ctx) & JANET_MARSHAL_UNSAFE)) { janet_panic("can only marshal stream with unsafe flag"); } + s->flags &= ~JANET_STREAM_NODUPS; /* This stream now might be duplicated, invalidates some EV optimizations */ janet_marshal_abstract(ctx, p); janet_marshal_int(ctx, (int32_t) s->flags); janet_marshal_ptr(ctx, s->methods); @@ -467,7 +465,7 @@ static void janet_stream_marshal(void *p, JanetMarshalContext *ctx) { } static void *janet_stream_unmarshal(JanetMarshalContext *ctx) { - if (!(ctx->flags & JANET_MARSHAL_UNSAFE)) { + if (!(janet_unmarshal_flags(ctx) & JANET_MARSHAL_UNSAFE)) { janet_panic("can only unmarshal stream with unsafe flag"); } JanetStream *p = janet_unmarshal_abstract(ctx, sizeof(JanetStream)); @@ -515,18 +513,18 @@ const JanetAbstractType janet_stream_type = { /* 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)) { + if (fiber->gc.flags & JANET_FIBER_EV_GCFLAG_CANCELED) return; + if (!(fiber->gc.flags & JANET_FIBER_EV_GCFLAG_ROOT)) { + fiber->gc.flags |= JANET_FIBER_EV_GCFLAG_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 (sig == JANET_SIGNAL_ERROR) fiber->gc.flags |= JANET_FIBER_EV_GCFLAG_CANCELED; if (soon) { - janet_q_push_head(&janet_vm.spawn, &t, sizeof(t)); + janet_assert(!janet_q_push_head(&janet_vm.spawn, &t, sizeof(t)), "schedule queue overflow"); } else { - janet_q_push(&janet_vm.spawn, &t, sizeof(t)); + janet_assert(!janet_q_push(&janet_vm.spawn, &t, sizeof(t)), "schedule queue overflow"); } } @@ -539,6 +537,9 @@ void janet_schedule_soon(JanetFiber *fiber, Janet value, JanetSignal sig) { } void janet_cancel(JanetFiber *fiber, Janet value) { + if (!(fiber->gc.flags & JANET_FIBER_EV_GCFLAG_ROOT)) { + janet_panic("cannot cancel non-task fiber"); + } janet_schedule_signal(fiber, value, JANET_SIGNAL_ERROR); } @@ -610,7 +611,7 @@ void janet_ev_init_common(void) { #if JANET_ANDROID static void janet_timeout_stop(int sig_num) { if (sig_num == SIGUSR1) { - pthread_exit(0); + pthread_exit(NULL); } } #endif @@ -699,7 +700,7 @@ static DWORD WINAPI janet_timeout_body(LPVOID ptr) { DWORD duration = (DWORD)round(tto.sec * 1000); DWORD res = WAIT_TIMEOUT; JanetTimestamp wait_end = ts_now(); - for (size_t i = 1; res == WAIT_TIMEOUT && (wait_end - wait_begin) < duration; i++) { + for (DWORD i = 1; res == WAIT_TIMEOUT && (wait_end - wait_begin) < duration; i++) { res = WaitForSingleObject(tto.cancel_event, (duration + i)); wait_end = ts_now(); } @@ -956,11 +957,12 @@ static void janet_thread_chan_cb(JanetEVGenericMessage msg) { janet_schedule(fiber, janet_wrap_nil()); } } else if (mode != JANET_CP_MODE_CLOSE) { - /* Fiber has already been cancelled or resumed. */ + /* Fiber has already been canceled 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; + int sent = 0; while (!janet_q_pop(&channel->read_pending, &reader, sizeof(reader))) { JanetVM *vm = reader.thread; if (!vm) continue; @@ -971,8 +973,12 @@ static void janet_thread_chan_cb(JanetEVGenericMessage msg) { msg.argp = channel; msg.argj = x; janet_ev_post_event(vm, janet_thread_chan_cb, msg); + sent = 1; break; } + if (!sent) { + janet_chan_unpack(channel, &x, 1); + } } else { JanetChannelPending writer; while (!janet_q_pop(&channel->write_pending, &writer, sizeof(writer))) { @@ -998,14 +1004,14 @@ static void janet_thread_chan_cb(JanetEVGenericMessage msg) { 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"); } + if (janet_chan_pack(channel, &x)) { + janet_chan_unlock(channel); + janet_panicf("failed to pack value for channel: %v", x); + } int is_threaded = janet_chan_is_threaded(channel); if (is_threaded) { /* don't dereference fiber from another thread */ @@ -1018,6 +1024,7 @@ static int janet_channel_push_with_lock(JanetChannel *channel, Janet x, int mode if (is_empty) { /* No pending reader */ if (janet_q_push(&channel->items, &x, sizeof(Janet))) { + janet_chan_unpack(channel, &x, 1); janet_chan_unlock(channel); janet_panicf("channel overflow: %v", x); } else if (janet_q_count(&channel->items) > channel->limit) { @@ -1051,6 +1058,9 @@ static int janet_channel_push_with_lock(JanetChannel *channel, Janet x, int mode msg.argj = x; if (vm) { janet_ev_post_event(vm, janet_thread_chan_cb, msg); + } else { + /* If no vm to send to, we must clean up (unpack) the packed payload to avoid leak */ + janet_chan_unpack(channel, &x, 1); } } else { if (reader.mode == JANET_CP_MODE_CHOICE_READ) { @@ -1082,7 +1092,7 @@ static int janet_channel_pop_with_lock(JanetChannel *channel, Janet *item, int i 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 + if (is_choice == 2) return 0; /* Skip pending read */ JanetChannelPending pending; pending.thread = &janet_vm; pending.fiber = janet_vm.root_fiber, @@ -1160,7 +1170,7 @@ JanetChannel *janet_channel_make(uint32_t limit) { 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); + janet_chan_init(channel, (int32_t) limit, 1); return channel; } @@ -1196,20 +1206,6 @@ JANET_CORE_FN(cfun_channel_pop, 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 " @@ -1238,29 +1234,27 @@ JANET_CORE_FN(cfun_channel_choice, 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); } + janet_chan_unlock(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); } + janet_chan_unlock(chan); } } @@ -1269,11 +1263,13 @@ JANET_CORE_FN(cfun_channel_choice, 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); } } @@ -1376,7 +1372,7 @@ JANET_CORE_FN(cfun_channel_close, janet_ev_post_event(vm, janet_thread_chan_cb, msg); } } else { - if (janet_fiber_can_resume(writer.fiber)) { + 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 { @@ -1399,7 +1395,7 @@ JANET_CORE_FN(cfun_channel_close, janet_ev_post_event(vm, janet_thread_chan_cb, msg); } } else { - if (janet_fiber_can_resume(reader.fiber)) { + 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 { @@ -1469,11 +1465,12 @@ static void *janet_chanat_unmarshal(JanetMarshalContext *ctx) { int32_t limit = janet_unmarshal_int(ctx); int32_t count = janet_unmarshal_int(ctx); if (count < 0) janet_panic("invalid negative channel count"); + if (count > limit) janet_panic("invalid 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)); + janet_assert(!janet_q_push(&abst->items, &item, sizeof(item)), "bad unmarshal channel"); } return abst; } @@ -1535,8 +1532,8 @@ JanetFiber *janet_loop1(void) { 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.fiber->gc.flags & JANET_FIBER_EV_GCFLAG_SUSPENDED) janet_ev_dec_refcount(); + task.fiber->gc.flags &= ~(JANET_FIBER_EV_GCFLAG_CANCELED | JANET_FIBER_EV_GCFLAG_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); @@ -1546,7 +1543,7 @@ JanetFiber *janet_loop1(void) { 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; + task.fiber->gc.flags |= JANET_FIBER_EV_GCFLAG_SUSPENDED; janet_ev_inc_refcount(); } if (NULL == sv) { @@ -1556,7 +1553,7 @@ JanetFiber *janet_loop1(void) { } 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); + task.fiber, chan->is_threaded), 2); } else if (!is_suspended) { janet_stacktrace_ext(task.fiber, res, ""); } @@ -1713,20 +1710,20 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp to) { janet_free(response); } else { /* Normal event */ + JanetOverlapped *jo = (JanetOverlapped *) overlapped; JanetStream *stream = (JanetStream *) completionKey; JanetFiber *fiber = NULL; - if (stream->read_fiber && stream->read_fiber->ev_state == overlapped) { + if (stream->read_fiber && stream->read_fiber->ev_state == jo) { fiber = stream->read_fiber; - } else if (stream->write_fiber && stream->write_fiber->ev_state == overlapped) { + } else if (stream->write_fiber && stream->write_fiber->ev_state == jo) { 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; + jo->bytes_transfered = (ULONG_PTR) num_bytes_transferred; fiber->ev_callback(fiber, result ? JANET_ASYNC_EVENT_COMPLETE : JANET_ASYNC_EVENT_FAILED); } else { - janet_free((void *) overlapped); + janet_free((void *) jo); janet_ev_dec_refcount(); } janet_stream_checktoclose(stream); @@ -1787,6 +1784,18 @@ void janet_stream_level_triggered(JanetStream *stream) { janet_register_stream_impl(stream, 1, 0); } +void janet_unregister_stream(JanetStream *stream) { + if (stream->flags & JANET_STREAM_NODUPS) return; + int status; + do { + status = epoll_ctl(janet_vm.epoll, EPOLL_CTL_DEL, stream->handle, NULL); + } while (status == -1 && errno == EINTR); + if (status == -1) { + janet_panicv(janet_ev_lasterr()); + } + stream->flags |= JANET_STREAM_UNREGISTERED; +} + #define JANET_EPOLL_MAX_EVENTS 64 void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { struct itimerspec its; @@ -1963,7 +1972,25 @@ void janet_stream_level_triggered(JanetStream *stream) { janet_register_stream_impl(stream, 0); } -#define JANET_KQUEUE_MAX_EVENTS 64 +void janet_unregister_stream(JanetStream *stream) { + if (stream->flags & JANET_STREAM_NODUPS) return; + 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); + /* Status might be -1 on BSDs for subprocesses */ + stream->flags |= JANET_STREAM_UNREGISTERED; +} + +#define JANET_KQUEUE_MAX_EVENTS 512 void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { /* Poll for events */ @@ -2027,6 +2054,7 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) { void janet_ev_init(void) { janet_ev_init_common(); + /* TODO - replace selfpipe with EVFILT_USER (or other events) */ janet_ev_setup_selfpipe(); janet_vm.kq = kqueue(); janet_vm.timer_enabled = 0; @@ -2085,6 +2113,18 @@ void janet_register_stream(JanetStream *stream) { janet_vm.stream_count = new_count; } +void janet_unregister_stream(JanetStream *stream) { + 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--; + stream->flags |= JANET_STREAM_UNREGISTERED; +} + void janet_stream_edge_triggered(JanetStream *stream) { (void) stream; } @@ -2326,6 +2366,14 @@ void janet_ev_threaded_call(JanetThreadedSubroutine fp, JanetEVGenericMessage ar /* Default callback for janet_ev_threaded_await. */ void janet_ev_default_threaded_callback(JanetEVGenericMessage return_value) { if (return_value.fiber == NULL) { + /* Clean up */ + switch (return_value.tag) { + default: + case JANET_EV_TCTAG_STRINGF: + case JANET_EV_TCTAG_ERR_STRINGF: + janet_free(return_value.argp); + break; + } return; } if (janet_fiber_can_resume(return_value.fiber)) { @@ -2340,7 +2388,6 @@ void janet_ev_default_threaded_callback(JanetEVGenericMessage return_value) { 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)); @@ -2348,7 +2395,6 @@ void janet_ev_default_threaded_callback(JanetEVGenericMessage return_value) { 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)); @@ -2358,6 +2404,14 @@ void janet_ev_default_threaded_callback(JanetEVGenericMessage return_value) { break; } } + /* Clean up */ + switch (return_value.tag) { + default: + case JANET_EV_TCTAG_STRINGF: + case JANET_EV_TCTAG_ERR_STRINGF: + janet_free(return_value.argp); + break; + } janet_gcunroot(janet_wrap_fiber(return_value.fiber)); } @@ -2411,7 +2465,7 @@ Janet janet_ev_lasterr(void) { msgbuf, sizeof(msgbuf), NULL); - if (!*msgbuf) sprintf(msgbuf, "%d", code); + if (!*msgbuf) snprintf(msgbuf, sizeof(msgbuf), "%d", code); char *c = msgbuf; while (*c) { if (*c == '\n' || *c == '\r') { @@ -2438,7 +2492,7 @@ typedef enum { typedef struct { #ifdef JANET_WINDOWS - OVERLAPPED overlapped; + JanetOverlapped overlapped; DWORD flags; #ifdef JANET_NET WSABUF wbuf; @@ -2473,7 +2527,7 @@ void ev_callback_read(JanetFiber *fiber, JanetAsyncEvent event) { case JANET_ASYNC_EVENT_FAILED: case JANET_ASYNC_EVENT_COMPLETE: { /* Called when read finished */ - uint32_t ev_bytes = (uint32_t) state->overlapped.InternalHigh; + uint32_t ev_bytes = (uint32_t) state->overlapped.bytes_transfered; state->bytes_read += ev_bytes; if (state->bytes_read == 0 && (state->mode != JANET_ASYNC_READMODE_RECVFROM)) { janet_schedule(fiber, janet_wrap_nil()); @@ -2505,7 +2559,7 @@ void ev_callback_read(JanetFiber *fiber, JanetAsyncEvent event) { /* 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)); + memset(&(state->overlapped), 0, sizeof(JanetOverlapped)); int status; #ifdef JANET_NET if (state->mode == JANET_ASYNC_READMODE_RECVFROM) { @@ -2513,7 +2567,7 @@ void ev_callback_read(JanetFiber *fiber, JanetAsyncEvent event) { 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); + NULL, &state->flags, &state->from, &state->fromlen, &state->overlapped.as.wsaoverlapped, NULL); if (status && (WSA_IO_PENDING != WSAGetLastError())) { janet_cancel(fiber, janet_ev_lasterr()); janet_async_end(fiber); @@ -2524,9 +2578,9 @@ void ev_callback_read(JanetFiber *fiber, JanetAsyncEvent event) { { /* 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; + state->overlapped.as.overlapped.Offset = (DWORD) state->bytes_read; - status = ReadFile(stream->handle, state->chunk_buf, chunk_size, NULL, &state->overlapped); + status = ReadFile(stream->handle, state->chunk_buf, chunk_size, NULL, &state->overlapped.as.overlapped); if (!status && (ERROR_IO_PENDING != GetLastError())) { if (GetLastError() == ERROR_BROKEN_PIPE) { if (state->bytes_read) { @@ -2682,7 +2736,7 @@ typedef enum { typedef struct { #ifdef JANET_WINDOWS - OVERLAPPED overlapped; + JanetOverlapped overlapped; DWORD flags; #ifdef JANET_NET WSABUF wbuf; @@ -2723,7 +2777,7 @@ void ev_callback_write(JanetFiber *fiber, JanetAsyncEvent event) { case JANET_ASYNC_EVENT_FAILED: case JANET_ASYNC_EVENT_COMPLETE: { /* Called when write finished */ - uint32_t ev_bytes = (uint32_t) state->overlapped.InternalHigh; + uint32_t ev_bytes = (uint32_t) state->overlapped.bytes_transfered; if (ev_bytes == 0 && (state->mode != JANET_ASYNC_WRITEMODE_SENDTO)) { janet_cancel(fiber, janet_cstringv("disconnect")); janet_async_end(fiber); @@ -2752,7 +2806,7 @@ void ev_callback_write(JanetFiber *fiber, JanetAsyncEvent event) { bytes = state->src.str; len = janet_string_length(bytes); } - memset(&(state->overlapped), 0, sizeof(WSAOVERLAPPED)); + memset(&(state->overlapped), 0, sizeof(JanetOverlapped)); int status; #ifdef JANET_NET @@ -2762,7 +2816,7 @@ void ev_callback_write(JanetFiber *fiber, JanetAsyncEvent event) { 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); + status = WSASendTo(sock, &state->wbuf, 1, NULL, state->flags, to, tolen, &state->overlapped.as.wsaoverlapped, NULL); if (status) { if (WSA_IO_PENDING == WSAGetLastError()) { janet_async_in_flight(fiber); @@ -2785,9 +2839,9 @@ void ev_callback_write(JanetFiber *fiber, JanetAsyncEvent event) { * 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); + state->overlapped.as.overlapped.Offset = (DWORD) 0xFFFFFFFF; + state->overlapped.as.overlapped.OffsetHigh = (DWORD) 0xFFFFFFFF; + status = WriteFile(stream->handle, bytes, len, NULL, &state->overlapped.as.overlapped); if (!status) { if (ERROR_IO_PENDING == GetLastError()) { janet_async_in_flight(fiber); @@ -2943,10 +2997,11 @@ int janet_make_pipe(JanetHandle handles[2], int mode) { if (!CreatePipe(handles, handles + 1, &saAttr, 0)) return -1; return 0; } - sprintf(PipeNameBuffer, - "\\\\.\\Pipe\\JanetPipeFile.%08x.%08x", - (unsigned int) GetCurrentProcessId(), - (unsigned int) InterlockedIncrement(&PipeSerialNumber)); + snprintf(PipeNameBuffer, + sizeof(PipeNameBuffer), + "\\\\.\\Pipe\\JanetPipeFile.%08x.%08x", + (unsigned int) GetCurrentProcessId(), + (unsigned int) InterlockedIncrement(&PipeSerialNumber)); /* server handle goes to subprocess */ shandle = CreateNamedPipeA( @@ -3002,12 +3057,14 @@ error: 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. " - "Optionally pass a value to resume with, otherwise resumes with nil. Returns the fiber. " - "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.") { + "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); @@ -3033,6 +3090,9 @@ JANET_CORE_FN(cfun_ev_go, 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); @@ -3048,6 +3108,7 @@ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) { const uint8_t *endbytes = nextbytes + buffer->count; uint32_t flags = args.tag; args.tag = 0; + args.argp = NULL; janet_init(); janet_vm.sandbox_flags = (uint32_t) args.argi; JanetTryState tstate; @@ -3058,7 +3119,7 @@ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) { 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_assert(janet_checktype(aregv, JANET_TABLE), "expected table for abstract registry"); janet_vm.abstract_registry = janet_unwrap_table(aregv); janet_gcroot(janet_wrap_table(janet_vm.abstract_registry)); } @@ -3078,9 +3139,7 @@ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) { 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_assert(count <= (endbytes - nextbytes - sizeof(count1)) / sizeof(JanetCFunRegistry), "thread message invalid"); janet_vm.registry_count = count; janet_vm.registry_cap = count; janet_vm.registry = janet_malloc(count * sizeof(JanetCFunRegistry)); @@ -3099,14 +3158,13 @@ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) { 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); - } + janet_assert(janet_checktype(fiberv, JANET_FUNCTION), "expected function or fiber"); JanetFunction *func = janet_unwrap_function(fiberv); + /* TODO - normal panics here do not seem to work correctly on Wine + Mingw. This needs to be investigated, and while it appears to be related to longjmp behavior + * on the platform not working correctly, it is not obvious the issue is. That said, we probably should assert and hard-exit anyway if there is an issue there. */ + janet_assert(func->def->min_arity >= 0 && func->def->min_arity <= 1, "thread function must accept 0 or 1 arguments"); fiber = janet_fiber(func, 64, func->def->min_arity, &value); - if (fiber == NULL) { - janet_panicf("thread function must accept 0 or 1 arguments"); - } + janet_assert(fiber != NULL, "bad fiber in thread setup"); fiber->flags |= JANET_FIBER_MASK_ERROR | JANET_FIBER_MASK_USER0 | @@ -3125,7 +3183,9 @@ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) { janet_schedule(fiber, value); janet_loop(); args.tag = JANET_EV_TCTAG_NIL; + janet_restore(&tstate); } else { + janet_restore(&tstate); void *supervisor = janet_vm.user; if (NULL != supervisor) { /* Got a supervisor, write error there */ @@ -3142,14 +3202,15 @@ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) { /* 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)); + JanetString msg = janet_unwrap_string(tstate.payload); + args.argp = janet_malloc(janet_string_length(msg) + 1); + memcpy(args.argp, msg, janet_string_length(msg) + 1); } 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(); @@ -3168,9 +3229,17 @@ JANET_CORE_FN(cfun_ev_thread, "* `: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); + if (janet_checktype(argv[0], JANET_FUNCTION)) { + JanetFunction *func = janet_getfunction(argv, 0); + if (func->def->arity < 0 || func->def->min_arity > 1) { + janet_panic("function must take 0 or 1 arguments"); + } + } else { + janet_getfiber(argv, 0); /* arg check for fiber */ + } uint64_t flags = 0; if (argc >= 3) { flags = janet_getflags(argv, 2, "nact"); @@ -3316,7 +3385,8 @@ JANET_CORE_FN(cfun_ev_deadline, JANET_CORE_FN(cfun_ev_cancel, "(ev/cancel fiber err)", - "Cancel a suspended fiber in the event loop. Differs from cancel in that it returns the canceled fiber immediately.") { + "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]; @@ -3506,6 +3576,7 @@ static JanetFile *get_file_for_stream(JanetStream *stream) { } if (index == 0) return NULL; /* duplicate handle when converting stream to file */ + stream->flags &= ~JANET_STREAM_NODUPS; #ifdef JANET_WINDOWS int htype = 0; if (fmt[0] == 'r' && fmt[1] == '+') { @@ -3549,7 +3620,7 @@ JANET_CORE_FN(janet_cfun_to_file, JANET_CORE_FN(janet_cfun_ev_all_tasks, "(ev/all-tasks)", - "Get an array of all active fibers that are being used by the scheduler.") { + "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); diff --git a/src/core/features.h b/src/core/features.h index d799880a..19562a74 100644 --- a/src/core/features.h +++ b/src/core/features.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -45,6 +45,9 @@ #ifdef __linux__ #define _GNU_SOURCE #endif +#ifdef __gnu_hurd__ +#define _GNU_SOURCE +#endif #if defined(WIN32) || defined(_WIN32) #define WIN32_LEAN_AND_MEAN diff --git a/src/core/ffi.c b/src/core/ffi.c index f14ff2f7..d638e896 100644 --- a/src/core/ffi.c +++ b/src/core/ffi.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -1344,6 +1344,15 @@ 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; @@ -1493,6 +1502,10 @@ static Janet janet_ffi_win64(JanetFFISignature *signature, void *function_pointe 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 @@ -1615,7 +1628,11 @@ JANET_CORE_FN(cfun_ffi_jitfn, fn->size = 0; #ifdef JANET_WINDOWS void *ptr = VirtualAlloc(NULL, alloc_size, MEM_COMMIT | MEM_RESERVE, PAGE_READWRITE); -#elif defined(MAP_ANONYMOUS) + if (!ptr) { + janet_panic("failed to allocate writable memory"); + } +#else +#ifdef 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 */ @@ -1625,9 +1642,10 @@ JANET_CORE_FN(cfun_ffi_jitfn, /* #define MAP_ANONYMOUS 0x20 should work, though. */ void *ptr = mmap(0, alloc_size, PROT_READ | PROT_WRITE, MAP_PRIVATE, -1, 0); #endif - if (!ptr) { + if (ptr == MAP_FAILED) { janet_panic("failed to memory map writable memory"); } +#endif memcpy(ptr, bytes.bytes, bytes.len); #ifdef JANET_WINDOWS DWORD old = 0; diff --git a/src/core/fiber.c b/src/core/fiber.c index 72d8f2de..f70a2683 100644 --- a/src/core/fiber.c +++ b/src/core/fiber.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -106,7 +106,7 @@ static void janet_fiber_refresh_memory(JanetFiber *fiber) { if (NULL == newData) { JANET_OUT_OF_MEMORY; } - memcpy(newData, fiber->data, fiber->capacity * sizeof(Janet)); + memcpy(newData, fiber->data, n * sizeof(Janet)); janet_free(fiber->data); fiber->data = newData; } @@ -180,7 +180,8 @@ void janet_fiber_pushn(JanetFiber *fiber, const Janet *arr, int32_t n) { /* 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)); + if (n & 1) n--; + JanetKV *st = janet_struct_begin(n); for (; i < n; i += 2) { janet_struct_put(st, args[i], args[i + 1]); } @@ -228,6 +229,7 @@ int janet_fiber_funcframe(JanetFiber *fiber, JanetFunction *func) { /* Check varargs */ if (func->def->flags & JANET_FUNCDEF_FLAG_VARARG) { int32_t tuplehead = fiber->frame + func->def->arity; + janet_assert(tuplehead > 0, "fiber stack overflow"); int st = func->def->flags & JANET_FUNCDEF_FLAG_STRUCTARG; if (tuplehead >= oldtop) { fiber->data[tuplehead] = st @@ -346,9 +348,6 @@ int janet_fiber_funcframe_tail(JanetFiber *fiber, JanetFunction *func) { #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); @@ -378,7 +377,7 @@ int janet_fiber_funcframe_tail(JanetFiber *fiber, JanetFunction *func) { stacksize = fiber->stacktop - fiber->stackstart; } - if (stacksize) memmove(stack, args, stacksize * sizeof(Janet)); + if (stacksize) memmove(fiber->data + fiber->frame, fiber->data + fiber->stackstart, stacksize * sizeof(Janet)); /* Nil unset locals (Needed for functional correctness) */ for (i = fiber->frame + stacksize; i < nextframetop; ++i) @@ -592,8 +591,8 @@ JANET_CORE_FN(cfun_fiber_status, "* :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") { + "* :new - the fiber has just been created and not yet run\n" + "* :alive - the fiber is currently running and cannot be resumed") { janet_fixarity(argc, 1); JanetFiber *fiber = janet_getfiber(argv, 0); uint32_t s = janet_fiber_status(fiber); @@ -610,8 +609,9 @@ JANET_CORE_FN(cfun_fiber_current, 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.") { + "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); diff --git a/src/core/fiber.h b/src/core/fiber.h index 8626e89c..56c79174 100644 --- a/src/core/fiber.h +++ b/src/core/fiber.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -56,12 +56,14 @@ #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 +/* Flags on the gc header (don't confuse flags with gc.flags!) */ +/* Don't collide with JANET_FIBER_STATUS_MASK to enable flag smuggling in vm.c */ +#define JANET_FIBER_EV_GCFLAG_CANCELED 0x1000000 +#define JANET_FIBER_EV_GCFLAG_SUSPENDED 0x2000000 +#define JANET_FIBER_EV_GCFLAG_ROOT 0x4000000 -/* used only on windows, should otherwise be unset */ +/* Not on gc header */ +#define JANET_FIBER_EV_FLAG_IN_FLIGHT 0x1 #define janet_fiber_set_status(f, s) do {\ (f)->flags &= ~JANET_FIBER_STATUS_MASK;\ diff --git a/src/core/filewatch.c b/src/core/filewatch.c index 104ac832..7bf948f9 100644 --- a/src/core/filewatch.c +++ b/src/core/filewatch.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -38,6 +38,13 @@ #include #endif +#if defined(JANET_APPLE) || defined(JANET_BSD) +#include +#include +#include +#include +#endif + typedef struct { const char *name; uint32_t flag; @@ -85,11 +92,11 @@ static uint32_t decode_watch_flags(const Janet *options, int32_t n) { } JanetKeyword keyw = janet_unwrap_keyword(options[i]); const JanetWatchFlagName *result = janet_strbinsearch(watcher_flags_linux, - sizeof(watcher_flags_linux) / sizeof(JanetWatchFlagName), - sizeof(JanetWatchFlagName), - keyw); + sizeof(watcher_flags_linux) / sizeof(JanetWatchFlagName), + sizeof(JanetWatchFlagName), + keyw); if (!result) { - janet_panicf("unknown inotify flag %v", options[i]); + janet_panicf("unknown linux flag %v", options[i]); } flags |= result->flag; } @@ -128,8 +135,11 @@ static void janet_watcher_add(JanetWatcher *watcher, const char *path, uint32_t 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"); + Janet pathv = janet_cstringv(path); + Janet check = janet_table_get(watcher->watch_descriptors, pathv); + if (!janet_checktype(check, JANET_NUMBER)) { + janet_panic("bad watch descriptor"); + } int watch_handle = janet_unwrap_integer(check); int result; do { @@ -138,6 +148,10 @@ static void janet_watcher_remove(JanetWatcher *watcher, const char *path) { if (result == -1) { janet_panicv(janet_ev_lasterr()); } + /* + janet_table_put(watcher->watch_descriptors, pathv, janet_wrap_nil()); + janet_table_put(watcher->watch_descriptors, janet_wrap_integer(watch_handle), janet_wrap_nil()); + */ } static void watcher_callback_read(JanetFiber *fiber, JanetAsyncEvent event) { @@ -302,9 +316,9 @@ static uint32_t decode_watch_flags(const Janet *options, int32_t n) { } JanetKeyword keyw = janet_unwrap_keyword(options[i]); const JanetWatchFlagName *result = janet_strbinsearch(watcher_flags_windows, - sizeof(watcher_flags_windows) / sizeof(JanetWatchFlagName), - sizeof(JanetWatchFlagName), - keyw); + sizeof(watcher_flags_windows) / sizeof(JanetWatchFlagName), + sizeof(JanetWatchFlagName), + keyw); if (!result) { janet_panicf("unknown windows filewatch flag %v", options[i]); } @@ -326,7 +340,7 @@ static void janet_watcher_init(JanetWatcher *watcher, JanetChannel *channel, uin #define FILE_INFO_PADDING (4096 * 4) typedef struct { - OVERLAPPED overlapped; + JanetOverlapped overlapped; JanetStream *stream; JanetWatcher *watcher; JanetFiber *fiber; @@ -456,7 +470,7 @@ static void janet_watcher_add(JanetWatcher *watcher, const char *path, uint32_t 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 */ + ow->overlapped.as.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) { @@ -500,6 +514,254 @@ static void janet_watcher_unlisten(JanetWatcher *watcher) { janet_gcunroot(janet_wrap_abstract(watcher)); } +#elif defined(JANET_APPLE) || defined(JANET_BSD) + +/* kqueue implementation */ + +/* Cribbed from ev.c */ +#define EV_SETx(ev, a, b, c, d, e, f) EV_SET((ev), (a), (b), (c), (d), (e), ((__typeof__((ev)->udata))(f))) + +/* Different BSDs define different NOTE_* constants for different kinds of events. Use ifdef to + determine when they are available (assuming they are defines and not enums */ +static const JanetWatchFlagName watcher_flags_kqueue[] = { + { + "all", NOTE_ATTRIB | NOTE_DELETE | NOTE_EXTEND | NOTE_RENAME | NOTE_REVOKE | NOTE_WRITE | NOTE_LINK +#ifdef NOTE_CLOSE + | NOTE_CLOSE +#endif +#ifdef NOTE_CLOSE_WRITE + | NOTE_CLOSE_WRITE +#endif +#ifdef NOTE_OPEN + | NOTE_OPEN +#endif +#ifdef NOTE_READ + | NOTE_READ +#endif +#ifdef NOTE_FUNLOCK + | NOTE_FUNLOCK +#endif +#ifdef NOTE_TRUNCATE + | NOTE_TRUNCATE +#endif + }, + {"attrib", NOTE_ATTRIB}, +#ifdef NOTE_CLOSE + {"close", NOTE_CLOSE}, +#endif +#ifdef NOTE_CLOSE_WRITE + {"close-write", NOTE_CLOSE_WRITE}, +#endif + {"delete", NOTE_DELETE}, + {"extend", NOTE_EXTEND}, +#ifdef NOTE_FUNLOCK + {"funlock", NOTE_FUNLOCK}, +#endif + {"link", NOTE_LINK}, +#ifdef NOTE_OPEN + {"open", NOTE_OPEN}, +#endif +#ifdef NOTE_READ + {"read", NOTE_READ}, +#endif + {"rename", NOTE_RENAME}, + {"revoke", NOTE_REVOKE}, +#ifdef NOTE_TRUNCATE + {"truncate", NOTE_TRUNCATE}, +#endif + {"write", NOTE_WRITE}, +}; + +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_kqueue, + sizeof(watcher_flags_kqueue) / sizeof(JanetWatchFlagName), + sizeof(JanetWatchFlagName), + keyw); + if (!result) { + janet_panicf("unknown bsd flag %v", options[i]); + } + flags |= result->flag; + } + return flags; +} + +static void janet_watcher_init(JanetWatcher *watcher, JanetChannel *channel, uint32_t default_flags) { + int kq = kqueue(); + watcher->watch_descriptors = janet_table(0); + watcher->channel = channel; + watcher->default_flags = default_flags; + watcher->is_watching = 0; + watcher->stream = janet_stream(kq, JANET_STREAM_READABLE, NULL); + janet_stream_level_triggered(watcher->stream); +} + +static void janet_watcher_add(JanetWatcher *watcher, const char *path, uint32_t flags) { + if (watcher->stream == NULL) janet_panic("watcher closed"); + int kq = watcher->stream->handle; + struct kevent kev = {0}; + /* Get file descriptor for path */ + int file_fd; + do { + file_fd = open(path, O_RDONLY); + } while (file_fd == -1 && errno == EINTR); + if (file_fd == -1) { + janet_panicf("failed to open: %v", janet_ev_lasterr()); + } + /* Watch for EVFILT_VNODE on the file descriptor */ + EV_SETx(&kev, file_fd, EVFILT_VNODE, EV_ADD | EV_ENABLE | EV_CLEAR, flags, 0, NULL); + int status; + do { + status = kevent(kq, &kev, 1, NULL, 0, NULL); + } while (status == -1 && errno == EINTR); + if (status == -1) { + close(file_fd); + janet_panicf("failed to listen: %v", janet_ev_lasterr()); + } + /* Bookkeeping */ + Janet name = janet_cstringv(path); + Janet wd = janet_wrap_integer(file_fd); + 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 pathv = janet_cstringv(path); + Janet check = janet_table_get(watcher->watch_descriptors, pathv); + if (!janet_checktype(check, JANET_NUMBER)) { + janet_panic("bad watch descriptor"); + } + /* Closing the file descriptor will also remove it from the kqueue */ + int wd = janet_unwrap_integer(check); + int result; + do { + result = close(wd); + } while (result != -1 && errno == EINTR); + if (result == -1) { + janet_panicv(janet_ev_lasterr()); + } + janet_table_put(watcher->watch_descriptors, pathv, janet_wrap_nil()); + janet_table_put(watcher->watch_descriptors, janet_wrap_integer(wd), janet_wrap_nil()); +} + +typedef struct { + JanetWatcher *watcher; + uint32_t cookie; +} KqueueWatcherState; + +static void watcher_callback_read(JanetFiber *fiber, JanetAsyncEvent event) { + JanetStream *stream = fiber->ev_stream; + KqueueWatcherState *state = fiber->ev_state; + JanetWatcher *watcher = state->watcher; + switch (event) { + 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; + } + case JANET_ASYNC_EVENT_HUP: + case JANET_ASYNC_EVENT_INIT: + break; + case JANET_ASYNC_EVENT_READ: { + /* Pump events from the sub kqueue */ + const int num_events = 512; /* Extra will be pumped after another event loop rotation. */ + struct kevent events[num_events]; + int kq = stream->handle; + int status; + do { + status = kevent(kq, NULL, 0, events, num_events, NULL); + } while (status == -1 && errno == EINTR); + if (status == -1) { + janet_schedule(fiber, janet_wrap_nil()); + janet_async_end(fiber); + break; + } + for (int i = 0; i < status; i++) { + state->cookie += 6700417; + struct kevent kev = events[i]; + /* TODO - avoid stat call here, maybe just when adding listener? */ + struct stat stat_buf = {0}; + int status; + do { + status = fstat(kev.ident, &stat_buf); + } while (status == -1 && errno == EINTR); + if (status == -1) continue; + int is_dir = S_ISDIR(stat_buf.st_mode); + Janet ident = janet_wrap_integer(kev.ident); + Janet path = janet_table_get(watcher->watch_descriptors, ident); + for (unsigned int j = 1; j < (sizeof(watcher_flags_kqueue) / sizeof(watcher_flags_kqueue[0])); j++) { + uint32_t flagcheck = watcher_flags_kqueue[j].flag; + if (kev.fflags & flagcheck) { + JanetKV *event = janet_struct_begin(6); + janet_struct_put(event, janet_ckeywordv("wd"), ident); + janet_struct_put(event, janet_ckeywordv("wd-path"), path); + janet_struct_put(event, janet_ckeywordv("cookie"), janet_wrap_number((double) state->cookie)); + janet_struct_put(event, janet_ckeywordv("type"), janet_ckeywordv(watcher_flags_kqueue[j].name)); + if (is_dir) { + /* Pass in directly */ + janet_struct_put(event, janet_ckeywordv("file-name"), janet_cstringv("")); + janet_struct_put(event, janet_ckeywordv("dir-name"), path); + } else { + /* Split path */ + 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) { + /* No path separators */ + janet_struct_put(event, janet_ckeywordv("dir-name"), janet_cstringv(".")); + janet_struct_put(event, janet_ckeywordv("file-name"), janet_wrap_string(spath)); + } else { + /* Found path separator */ + 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)))); + } + } + Janet eventv = janet_wrap_struct(janet_struct_end(event)); + janet_channel_give(watcher->channel, eventv); + } + } + } + break; + } + default: + 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); + KqueueWatcherState *state = janet_malloc(sizeof(KqueueWatcherState)); + state->watcher = 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)); +} + #else /* Default implementation */ @@ -521,23 +783,23 @@ static void janet_watcher_add(JanetWatcher *watcher, const char *path, uint32_t (void) watcher; (void) flags; (void) path; - janet_panic("nyi"); + janet_panic("filewatch not supported on this platform"); } static void janet_watcher_remove(JanetWatcher *watcher, const char *path) { (void) watcher; (void) path; - janet_panic("nyi"); + janet_panic("filewatch not supported on this platform"); } static void janet_watcher_listen(JanetWatcher *watcher) { (void) watcher; - janet_panic("nyi"); + janet_panic("filewatch not supported on this platform"); } static void janet_watcher_unlisten(JanetWatcher *watcher) { (void) watcher; - janet_panic("nyi"); + janet_panic("filewatch not supported on this platform"); } #endif @@ -573,7 +835,7 @@ static const JanetAbstractType janet_filewatch_at = { }; JANET_CORE_FN(cfun_filewatch_make, - "(filewatch/new channel &opt default-flags)", + "(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" @@ -582,10 +844,10 @@ JANET_CORE_FN(cfun_filewatch_make, "* `: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" + "Linux and the BSDs have the following extra properties on events:\n\n" + "* `:wd` -- the integer key returned by `filewatch/add` for the path that triggered this. This is a file descriptor integer on BSD and macos.\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" + "* `:cookie` -- a semi-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); @@ -597,9 +859,10 @@ JANET_CORE_FN(cfun_filewatch_make, } JANET_CORE_FN(cfun_filewatch_add, - "(filewatch/add watcher path &opt flags)", + "(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" + "FLAGS\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" @@ -626,6 +889,22 @@ JANET_CORE_FN(cfun_filewatch_add, "* `:open` - `IN_OPEN`\n\n" "* `:q-overflow` - `IN_Q_OVERFLOW`\n\n" "* `:unmount` - `IN_UNMOUNT`\n\n\n" + "BSDs and macos (flags correspond to `NOTE_*` flags from ). Not all flags are available on all systems:\n\n" + "* `:all` - `All available NOTE_* flags on the current platform`\n\n" + "* `:attrib` - `NOTE_ATTRIB`\n\n" + "* `:close-write` - `NOTE_CLOSE_WRITE`\n\n" + "* `:close` - `NOTE_CLOSE`\n\n" + "* `:delete` - `NOTE_DELETE`\n\n" + "* `:extend` - `NOTE_EXTEND`\n\n" + "* `:funlock` - `NOTE_FUNLOCK`\n\n" + "* `:link` - `NOTE_LINK`\n\n" + "* `:open` - `NOTE_OPEN`\n\n" + "* `:read` - `NOTE_READ`\n\n" + "* `:rename` - `NOTE_RENAME`\n\n" + "* `:revoke` - `NOTE_REVOKE`\n\n" + "* `:truncate` - `NOTE_TRUNCATE`\n\n" + "* `:write` - `NOTE_WRITE`\n\n\n" + "EVENT TYPES\n\n" "On Windows, events will have the following possible types:\n\n" "* `:unknown`\n\n" "* `:added`\n\n" @@ -633,7 +912,7 @@ JANET_CORE_FN(cfun_filewatch_add, "* `: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" + "On Linux and BSDs, 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); @@ -648,6 +927,7 @@ JANET_CORE_FN(cfun_filewatch_remove, "Remove a path from the watcher.") { janet_fixarity(argc, 2); JanetWatcher *watcher = janet_getabstract(argv, 0, &janet_filewatch_at); + /* TODO - pass string in directly to avoid extra allocation */ const char *path = janet_getcstring(argv, 1); janet_watcher_remove(watcher, path); return argv[0]; diff --git a/src/core/gc.c b/src/core/gc.c index 028d9b2a..a776fa9c 100644 --- a/src/core/gc.c +++ b/src/core/gc.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -336,6 +336,8 @@ static void janet_deinit_block(JanetGCObject *mem) { if (f->ev_state && !(f->flags & JANET_FIBER_EV_FLAG_IN_FLIGHT)) { janet_ev_dec_refcount(); janet_free(f->ev_state); + } else if (f->gc.flags & JANET_FIBER_EV_GCFLAG_SUSPENDED) { + janet_ev_dec_refcount(); } #endif janet_free(f->data); @@ -504,14 +506,7 @@ void janet_sweep() { if (head->type->gcperthread) { janet_assert(!head->type->gcperthread(head->data, head->size), "per-thread finalizer failed"); } - if (0 == janet_abstract_decref(abst)) { - /* Run finalizer */ - if (head->type->gc) { - janet_assert(!head->type->gc(head->data, head->size), "finalizer failed"); - } - /* Free memory */ - janet_free(janet_abstract_head(abst)); - } + janet_abstract_decref_maybe_free(abst); /* Mark as tombstone in place */ items[i].key = janet_wrap_nil(); @@ -597,7 +592,9 @@ void janet_collect(void) { #ifdef JANET_EV janet_ev_mark(); #endif - janet_mark_fiber(janet_vm.root_fiber); + if (janet_vm.root_fiber != NULL) { /* Can be NULL if janet_collect called outside of interpreter loop */ + 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) { @@ -682,12 +679,7 @@ void janet_clear_memory(void) { if (head->type->gcperthread) { janet_assert(!head->type->gcperthread(head->data, head->size), "per-thread finalizer failed"); } - if (0 == janet_abstract_decref(abst)) { - if (head->type->gc) { - janet_assert(!head->type->gc(head->data, head->size), "finalizer failed"); - } - janet_free(janet_abstract_head(abst)); - } + janet_abstract_decref_maybe_free(abst); } } #endif diff --git a/src/core/gc.h b/src/core/gc.h index 37318eee..89d00302 100644 --- a/src/core/gc.h +++ b/src/core/gc.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/core/inttypes.c b/src/core/inttypes.c index db0d2b28..ad659faf 100644 --- a/src/core/inttypes.c +++ b/src/core/inttypes.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose & contributors +* 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 @@ -333,7 +333,7 @@ static int compare_uint64_double(uint64_t x, double y) { } } -static Janet cfun_it_s64_compare(int32_t argc, Janet *argv) { +static JANET_CFUNCTION_ALIGN 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"); @@ -368,7 +368,7 @@ static Janet cfun_it_s64_compare(int32_t argc, Janet *argv) { return janet_wrap_nil(); } -static Janet cfun_it_u64_compare(int32_t argc, Janet *argv) { +static JANET_CFUNCTION_ALIGN 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"); @@ -416,7 +416,7 @@ static Janet cfun_it_u64_compare(int32_t argc, Janet *argv) { * 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) { \ +static JANET_CFUNCTION_ALIGN 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]); \ @@ -427,7 +427,7 @@ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ } \ #define OPMETHODINVERT(T, type, name, oper) \ -static Janet cfun_it_##type##_##name##i(int32_t argc, Janet *argv) { \ +static JANET_CFUNCTION_ALIGN 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]); \ @@ -437,7 +437,7 @@ static Janet cfun_it_##type##_##name##i(int32_t argc, Janet *argv) { \ } \ #define UNARYMETHOD(T, type, name, oper) \ -static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ +static JANET_CFUNCTION_ALIGN 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])); \ @@ -450,7 +450,7 @@ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ #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) { \ +static JANET_CFUNCTION_ALIGN 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]); \ @@ -463,7 +463,7 @@ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ } \ #define DIVMETHODINVERT(T, type, name, oper) \ -static Janet cfun_it_##type##_##name##i(int32_t argc, Janet *argv) { \ +static JANET_CFUNCTION_ALIGN 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]); \ @@ -474,7 +474,7 @@ static Janet cfun_it_##type##_##name##i(int32_t argc, Janet *argv) { \ } \ #define DIVMETHOD_SIGNED(T, type, name, oper) \ -static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ +static JANET_CFUNCTION_ALIGN 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]); \ @@ -488,7 +488,7 @@ static Janet cfun_it_##type##_##name(int32_t argc, Janet *argv) { \ } \ #define DIVMETHODINVERT_SIGNED(T, type, name, oper) \ -static Janet cfun_it_##type##_##name##i(int32_t argc, Janet *argv) { \ +static JANET_CFUNCTION_ALIGN 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]); \ @@ -499,7 +499,7 @@ static Janet cfun_it_##type##_##name##i(int32_t argc, Janet *argv) { \ return janet_wrap_abstract(box); \ } \ -static Janet cfun_it_s64_divf(int32_t argc, Janet *argv) { +static JANET_CFUNCTION_ALIGN 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]); @@ -510,7 +510,7 @@ static Janet cfun_it_s64_divf(int32_t argc, Janet *argv) { return janet_wrap_abstract(box); } -static Janet cfun_it_s64_divfi(int32_t argc, Janet *argv) { +static JANET_CFUNCTION_ALIGN 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]); @@ -521,7 +521,7 @@ static Janet cfun_it_s64_divfi(int32_t argc, Janet *argv) { return janet_wrap_abstract(box); } -static Janet cfun_it_s64_mod(int32_t argc, Janet *argv) { +static JANET_CFUNCTION_ALIGN 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]); @@ -535,7 +535,7 @@ static Janet cfun_it_s64_mod(int32_t argc, Janet *argv) { return janet_wrap_abstract(box); } -static Janet cfun_it_s64_modi(int32_t argc, Janet *argv) { +static JANET_CFUNCTION_ALIGN 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]); diff --git a/src/core/io.c b/src/core/io.c index 4d45caba..61488cb8 100644 --- a/src/core/io.c +++ b/src/core/io.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -43,6 +43,7 @@ static void *io_file_unmarshal(JanetMarshalContext *ctx); static Janet io_file_next(void *p, Janet key); #ifdef JANET_WINDOWS +#include #define ftell _ftelli64 #define fseek _fseeki64 #endif @@ -109,11 +110,12 @@ static int32_t checkflags(const uint8_t *str) { return flags; } -static void *makef(FILE *f, int32_t flags) { +static void *makef(FILE *f, int32_t flags, size_t bufsize) { JanetFile *iof = (JanetFile *) janet_abstract(&janet_file_type, sizeof(JanetFile)); iof->file = f; iof->flags = flags; -#ifndef JANET_WINDOWS + iof->vbufsize = bufsize; +#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)) @@ -164,8 +166,9 @@ JANET_CORE_FN(cfun_io_fopen, flags = JANET_FILE_READ; } FILE *f = fopen((const char *)fname, (const char *)fmode); + size_t bufsize = BUFSIZ; if (f != NULL) { -#ifndef JANET_WINDOWS +#if !(defined(JANET_WINDOWS) || defined(JANET_PLAN9)) struct stat st; fstat(fileno(f), &st); if (S_ISDIR(st.st_mode)) { @@ -173,7 +176,7 @@ JANET_CORE_FN(cfun_io_fopen, janet_panicf("cannot open directory: %s", fname); } #endif - size_t bufsize = janet_optsize(argv, argc, 2, BUFSIZ); + bufsize = janet_optsize(argv, argc, 2, BUFSIZ); if (bufsize != BUFSIZ) { int result = setvbuf(f, NULL, bufsize ? _IOFBF : _IONBF, bufsize); if (result) { @@ -181,7 +184,7 @@ JANET_CORE_FN(cfun_io_fopen, } } } - return f ? janet_makefile(f, flags) + return f ? janet_wrap_abstract(makef(f, flags, bufsize)) : (flags & JANET_FILE_NONIL) ? (janet_panicf("failed to open file %s: %s", fname, janet_strerror(errno)), janet_wrap_nil()) : janet_wrap_nil(); } @@ -249,9 +252,9 @@ JANET_CORE_FN(cfun_io_fread, /* Write bytes to a file */ JANET_CORE_FN(cfun_io_fwrite, - "(file/write f bytes)", - "Writes to a file. 'bytes' must be string, buffer, or symbol. Returns the " - "file.") { + "(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) @@ -408,21 +411,36 @@ static Janet io_file_next(void *p, Janet key) { static void io_file_marshal(void *p, JanetMarshalContext *ctx) { JanetFile *iof = (JanetFile *)p; - if (ctx->flags & JANET_MARSHAL_UNSAFE) { + if (janet_marshal_flags(ctx) & JANET_MARSHAL_UNSAFE) { janet_marshal_abstract(ctx, p); + int fno = -1; #ifdef JANET_WINDOWS - janet_marshal_int(ctx, _fileno(iof->file)); + if (iof->flags & JANET_FILE_NOT_CLOSEABLE) { + fno = _fileno(iof->file); + } else { + fno = _dup(_fileno(iof->file)); + } #else - janet_marshal_int(ctx, fileno(iof->file)); + if (iof->flags & JANET_FILE_NOT_CLOSEABLE) { + fno = fileno(iof->file); + } else { +#ifdef JANET_PLAN9 + fno = dup(fileno(iof->file), -1); +#else + fno = dup(fileno(iof->file)); #endif + } +#endif + janet_marshal_int(ctx, fno); janet_marshal_int(ctx, iof->flags); + janet_marshal_size(ctx, iof->vbufsize); } else { janet_panic("cannot marshal file in safe mode"); } } static void *io_file_unmarshal(JanetMarshalContext *ctx) { - if (ctx->flags & JANET_MARSHAL_UNSAFE) { + if (janet_unmarshal_flags(ctx) & 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); @@ -444,6 +462,11 @@ static void *io_file_unmarshal(JanetMarshalContext *ctx) { } else { iof->flags = flags; } + iof->vbufsize = janet_unmarshal_size(ctx); + if (iof->vbufsize != BUFSIZ) { + int result = setvbuf(iof->file, NULL, iof->vbufsize ? _IOFBF : _IONBF, iof->vbufsize); + janet_assert(!result, "unmarshal setvbuf"); + } return iof; } else { janet_panic("cannot unmarshal file in safe mode"); @@ -721,8 +744,15 @@ JANET_CORE_FN(cfun_io_eflush, void janet_dynprintf(const char *name, FILE *dflt_file, const char *format, ...) { va_list args; va_start(args, format); - Janet x = janet_dyn(name); - JanetType xtype = janet_type(x); + 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 */ @@ -778,11 +808,11 @@ FILE *janet_getfile(const Janet *argv, int32_t n, int32_t *flags) { } JanetFile *janet_makejfile(FILE *f, int32_t flags) { - return makef(f, flags); + return makef(f, flags, BUFSIZ); } Janet janet_makefile(FILE *f, int32_t flags) { - return janet_wrap_abstract(makef(f, flags)); + return janet_wrap_abstract(makef(f, flags, BUFSIZ)); } JanetAbstract janet_checkfile(Janet j) { diff --git a/src/core/marsh.c b/src/core/marsh.c index 13b3344b..b05a8682 100644 --- a/src/core/marsh.c +++ b/src/core/marsh.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -30,6 +30,7 @@ #include "util.h" #endif + typedef struct { JanetBuffer *buf; JanetTable seen; @@ -276,6 +277,8 @@ static void marshal_one_def(MarshalState *st, JanetFuncDef *def, int flags) { 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) @@ -431,6 +434,10 @@ void janet_marshal_abstract(JanetMarshalContext *ctx, void *abstract) { MARK_SEEN(); } +int janet_marshal_flags(JanetMarshalContext *ctx) { + return ctx->flags; +} + static void marshal_one_abstract(MarshalState *st, Janet x, int flags) { void *abstract = janet_unwrap_abstract(x); #ifdef JANET_EV @@ -914,6 +921,7 @@ static const uint8_t *unmarshal_one_def( 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 */ @@ -933,6 +941,8 @@ static const uint8_t *unmarshal_one_def( /* 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) @@ -1106,7 +1116,12 @@ static const uint8_t *unmarshal_one_fiber( } /* Allocate stack memory */ - fiber->capacity = fiber_stacktop + 10; + if (fiber_stacktop < INT32_MAX - 10) { + fiber->capacity = fiber_stacktop + 10; + } else { + /* Extra capacity is usually nice to avoid immediately reallocing on pushed arguments, but not needed */ + fiber->capacity = INT32_MAX; + } fiber->data = janet_malloc(sizeof(Janet) * fiber->capacity); if (!fiber->data) { JANET_OUT_OF_MEMORY; @@ -1291,6 +1306,10 @@ void *janet_unmarshal_abstract_threaded(JanetMarshalContext *ctx, size_t size) { #endif } +int janet_unmarshal_flags(JanetMarshalContext *ctx) { + return ctx->flags; +} + 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); @@ -1467,7 +1486,7 @@ static const uint8_t *unmarshal_one( /* Tuple */ Janet *tup = janet_tuple_begin(len); int32_t flag = readint(st, &data); - janet_tuple_flag(tup) |= flag << 16; + janet_tuple_flag(tup) |= (int32_t) (((uint32_t) flag) << 16); /* Avoid left shift of negative value */ for (int32_t i = 0; i < len; i++) { data = unmarshal_one(st, data, tup + i, flags + 1); } @@ -1693,6 +1712,7 @@ JANET_CORE_FN(cfun_unmarshal, "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; diff --git a/src/core/math.c b/src/core/math.c index 400ed7e4..4d0d6a53 100644 --- a/src/core/math.c +++ b/src/core/math.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -271,28 +271,30 @@ 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(asinh, "Returns the hyperbolic arcsine of x.") JANET_DEFINE_MATHOP(tan, "Returns the tangent of x.") JANET_DEFINE_MATHOP(tanh, "Returns the hyperbolic tangent of x.") -JANET_DEFINE_MATHOP(atanh, "Returns the hyperbolic arctangent 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(cbrt, "Returns the cube 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_MATHOP(log1p, "Returns (log base e of x) + 1 more accurately than (+ (math/log x) 1)") -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("abs", fabs, "Return the absolute value of x.") -JANET_DEFINE_NAMED_MATHOP("gamma", tgamma, "Returns gamma(x).") #define JANET_DEFINE_MATH2OP(name, fop, signature, doc)\ JANET_CORE_FN(janet_##name, signature, doc) {\ @@ -305,7 +307,9 @@ JANET_CORE_FN(janet_##name, signature, doc) {\ 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); @@ -386,7 +390,17 @@ void janet_lib_math(JanetTable *env) { 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), @@ -394,8 +408,6 @@ void janet_lib_math(JanetTable *env) { 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/atanh", janet_atanh), - JANET_CORE_REG("math/asinh", janet_asinh), JANET_CORE_REG("math/acosh", janet_acosh), JANET_CORE_REG("math/atan2", janet_atan2), JANET_CORE_REG("math/rng", cfun_rng_make), @@ -405,14 +417,8 @@ void janet_lib_math(JanetTable *env) { 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/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/trunc", janet_trunc), JANET_CORE_REG("math/round", janet_round), - JANET_CORE_REG("math/next", janet_nextafter), JANET_CORE_REG("math/gcd", janet_cfun_gcd), JANET_CORE_REG("math/lcm", janet_cfun_lcm), JANET_CORE_REG("math/frexp", janet_cfun_frexp), @@ -435,9 +441,9 @@ void janet_lib_math(JanetTable *env) { 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)"); + "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))"); + "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 diff --git a/src/core/net.c b/src/core/net.c index a8cdf47e..49bc52fb 100644 --- a/src/core/net.c +++ b/src/core/net.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose and contributors. +* 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 @@ -120,7 +120,55 @@ static void janet_net_socknoblock(JSock s) { #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 */ +#ifdef JANET_WINDOWS + +typedef struct NetStateConnect { + /* Only used for ConnectEx */ + JanetOverlapped overlapped; +} NetStateConnect; + +static LPFN_CONNECTEX lazy_get_connectex(JSock sock) { + /* Get ConnectEx */ + if (janet_vm.connect_ex_loaded) { + return janet_vm.connect_ex; + } + GUID guid = WSAID_CONNECTEX; + LPFN_CONNECTEX connect_ex_ptr = NULL; + DWORD byte_len = 0; + int success = WSAIoctl(sock, SIO_GET_EXTENSION_FUNCTION_POINTER, + (void *)&guid, sizeof(guid), + (void *)&connect_ex_ptr, sizeof(connect_ex_ptr), + &byte_len, NULL, NULL); + if (success) { + janet_vm.connect_ex = connect_ex_ptr; + } else { + janet_vm.connect_ex = NULL; + } + janet_vm.connect_ex_loaded = 1; + return janet_vm.connect_ex; +} + +#endif void net_callback_connect(JanetFiber *fiber, JanetAsyncEvent event) { JanetStream *stream = fiber->ev_stream; @@ -140,15 +188,21 @@ void net_callback_connect(JanetFiber *fiber, JanetAsyncEvent event) { return; } #ifdef JANET_WINDOWS + /* We should be using ConnectEx here */ int res = 0; int size = sizeof(res); - int r = getsockopt((SOCKET)stream->handle, SOL_SOCKET, SO_ERROR, (char *)&res, &size); + int r = getsockopt((SOCKET)stream->handle, SOL_SOCKET, SO_CONNECT_TIME, (char *)&res, &size); + if (r == NO_ERROR && res == (~0)) { + return; /* This apparently indicates we haven't yet gotten a connection */ + } + const int no_error = NO_ERROR; #else int res = 0; - socklen_t size = sizeof res; + socklen_t size = sizeof(res); int r = getsockopt(stream->handle, SOL_SOCKET, SO_ERROR, &res, &size); + const int no_error = 0; #endif - if (r == 0) { + if (r == no_error) { if (res == 0) { janet_schedule(fiber, janet_wrap_abstract(stream)); } else { @@ -162,8 +216,8 @@ void net_callback_connect(JanetFiber *fiber, JanetAsyncEvent event) { 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); +static JANET_NO_RETURN void net_sched_connect(JanetStream *stream, void *state) { + janet_async_start(stream, JANET_ASYNC_LISTEN_WRITE, net_callback_connect, state); } /* State machine for accepting connections. */ @@ -171,7 +225,7 @@ static JANET_NO_RETURN void net_sched_connect(JanetStream *stream) { #ifdef JANET_WINDOWS typedef struct { - WSAOVERLAPPED overlapped; + JanetOverlapped overlapped; JanetFunction *function; JanetStream *lstream; JanetStream *astream; @@ -234,7 +288,7 @@ void net_callback_accept(JanetFiber *fiber, JanetAsyncEvent event) { 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->overlapped, 0, sizeof(JanetOverlapped)); memset(&state->buf, 0, 1024); state->function = fun; state->lstream = stream; @@ -255,7 +309,7 @@ static int net_sched_accept_impl(NetStateAccept *state, JanetFiber *fiber, Janet 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)) { + if (FALSE == AcceptEx(lsock, asock, state->buf, 0, socksize, socksize, NULL, &state->overlapped.as.wsaoverlapped)) { int code = WSAGetLastError(); if (code == WSA_IO_PENDING) { /* indicates io is happening async */ @@ -551,15 +605,44 @@ JANET_CORE_FN(cfun_net_connect, if (socktype == SOCK_DGRAM) udp_flag = JANET_STREAM_UDPSERVER; JanetStream *stream = make_stream(sock, JANET_STREAM_READABLE | JANET_STREAM_WRITABLE | udp_flag); - /* Set up the socket for non-blocking IO before connecting */ - janet_net_socknoblock(sock); - /* Connect to socket */ #ifdef JANET_WINDOWS - int status = WSAConnect(sock, addr, addrlen, NULL, NULL, NULL, NULL); - int err = WSAGetLastError(); - freeaddrinfo(ai); + int status = 0; + int err = 0; + LPFN_CONNECTEX connect_ex = NULL; + if (socktype == SOCK_STREAM && ((connect_ex = lazy_get_connectex(sock)))) { + /* Prefer ConnecEx as it works well with overlapped IO. */ + janet_net_socknoblock(sock); + NetStateConnect *state = janet_malloc(sizeof(NetStateConnect)); + memset(state, 0, sizeof(NetStateConnect)); + BOOL success = connect_ex(sock, addr, addrlen, NULL, 0, NULL, &state->overlapped.as.overlapped); + freeaddrinfo(ai); + if (success) { + /* Did not fail */ + } else { + int err = WSAGetLastError(); + if (err == ERROR_IO_PENDING) { + /* Did not actually fail yet */ + } else { + janet_free(state); + Janet lasterr = janet_ev_lasterr(); + janet_panicf("could not connect socket (ConnectEx): %V", lasterr); + } + } + + net_sched_connect(stream, state); + } else { + /* Default to blocking connect if ConnectEx not available */ + status = WSAConnect(sock, addr, addrlen, NULL, NULL, NULL, NULL); + 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); @@ -572,10 +655,19 @@ JANET_CORE_FN(cfun_net_connect, } #endif - if (status) { + 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); @@ -584,14 +676,15 @@ JANET_CORE_FN(cfun_net_connect, } } - net_sched_connect(stream); + net_sched_connect(stream, NULL); } JANET_CORE_FN(cfun_net_socket, - "(net/socket &opt type)", + "(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.") { - janet_arity(argc, 0, 1); + "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); @@ -602,7 +695,14 @@ JANET_CORE_FN(cfun_net_socket, 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)); @@ -646,7 +746,7 @@ static const char *serverify_socket(JSock sfd, int reuse_addr, int reuse_port) { } } if (reuse_port) { -#ifdef SO_REUSEPORT +#if defined(SO_REUSEPORT) && !JANET_GNU_HURD if (setsockopt(sfd, SOL_SOCKET, SO_REUSEPORT, &enable, sizeof(int)) < 0) { return "setsockopt(SO_REUSEPORT) failed"; } @@ -1031,6 +1131,8 @@ static const struct sockopt_type sockopt_type_list[] = { #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 } }; @@ -1048,7 +1150,10 @@ JANET_CORE_FN(cfun_net_setsockopt, "- :ip-add-membership string\n" "- :ip-drop-membership string\n" "- :ipv6-join-group string\n" - "- :ipv6-leave-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); @@ -1067,6 +1172,7 @@ JANET_CORE_FN(cfun_net_setsockopt, } union { + unsigned char v_uchar; int v_int; struct ip_mreq v_mreq; #ifndef JANET_NO_IPV6 @@ -1081,8 +1187,19 @@ JANET_CORE_FN(cfun_net_setsockopt, val.v_int = janet_getboolean(argv, 2); optlen = sizeof(val.v_int); } else if (st->type == JANET_NUMBER) { +#if defined(JANET_BSD) || defined(JANET_ILLUMOS) + 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); @@ -1130,7 +1247,7 @@ static const JanetMethod net_stream_methods[] = { }; static JanetStream *make_stream(JSock handle, uint32_t flags) { - return janet_stream((JanetHandle) handle, flags | JANET_STREAM_SOCKET, net_stream_methods); + return janet_stream((JanetHandle) handle, flags | JANET_STREAM_SOCKET | JANET_STREAM_NODUPS, net_stream_methods); } void janet_lib_net(JanetTable *env) { @@ -1161,6 +1278,8 @@ void janet_net_init(void) { #ifdef JANET_WINDOWS WSADATA wsaData; janet_assert(!WSAStartup(MAKEWORD(2, 2), &wsaData), "could not start winsock"); + janet_vm.connect_ex_loaded = 0; + janet_vm.connect_ex = NULL; #endif } diff --git a/src/core/os.c b/src/core/os.c index 885b7b33..1f1d919c 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose and contributors. +* 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 @@ -40,6 +40,7 @@ #include #include #include +#include #ifdef JANET_BSD #include @@ -49,6 +50,11 @@ #include #endif +#ifdef JANET_GNU_HURD +/* Ideally we would try to dynamically allocate */ +#define PATH_MAX 8192 +#endif + #ifdef JANET_WINDOWS #include #include @@ -57,7 +63,9 @@ #include #define JANET_SPAWN_CHDIR #else +#ifndef JANET_PLAN9 #include +#endif #include #include #include @@ -68,7 +76,7 @@ #define environ (*_NSGetEnviron()) #include int chroot(const char *dirname); -#else +#elif !defined(JANET_PLAN9) extern char **environ; #endif #ifdef JANET_THREADS @@ -140,23 +148,27 @@ static void janet_unlock_environ(void) { #define janet_stringify(x) janet_stringify1(x) JANET_CORE_FN(os_which, - "(os/which)", - "Check the current operating system. Returns one of:\n\n" + "(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" + "* :hurd\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.") { - janet_fixarity(argc, 0); - (void) argv; + "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) @@ -171,6 +183,8 @@ JANET_CORE_FN(os_which, return janet_ckeywordv("web"); #elif defined(JANET_LINUX) return janet_ckeywordv("linux"); +#elif defined(JANET_GNU_HURD) + return janet_ckeywordv("hurd"); #elif defined(__FreeBSD__) return janet_ckeywordv("freebsd"); #elif defined(__NetBSD__) @@ -244,6 +258,7 @@ JANET_CORE_FN(os_compiler, "* :gcc\n\n" "* :clang\n\n" "* :msvc\n\n" + "* :kencc\n\n" "* :unknown\n\n") { janet_fixarity(argc, 0); (void) argv; @@ -253,6 +268,8 @@ JANET_CORE_FN(os_compiler, 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 @@ -267,6 +284,7 @@ JANET_CORE_FN(os_exit, "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); + janet_sandbox_assert(JANET_SANDBOX_EXIT); int status; if (argc == 0) { status = EXIT_SUCCESS; @@ -275,9 +293,14 @@ JANET_CORE_FN(os_exit, } else { status = EXIT_FAILURE; } + int force = (argc >= 2 && janet_truthy(argv[1])); janet_deinit(); - if (argc >= 2 && janet_truthy(argv[1])) { + if (force) { +#ifdef JANET_PLAN9 + exits(nil); +#else _Exit(status); +#endif } else { exit(status); } @@ -291,46 +314,43 @@ JANET_CORE_FN(os_cpu_count, "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); - Janet dflt = argc > 0 ? argv[0] : janet_wrap_nil(); + (void) argv; /* Prevent unused argument warning */ #ifdef JANET_WINDOWS - (void) dflt; SYSTEM_INFO info; GetSystemInfo(&info); return janet_wrap_integer(info.dwNumberOfProcessors); #elif defined(JANET_LINUX) - (void) dflt; 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) - (void) dflt; 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 dflt; + return argc > 0 ? argv[0] : janet_wrap_nil(); } return janet_wrap_integer(result); #elif defined(JANET_BSD) && defined(HW_NCPU) - (void) dflt; 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 dflt; + return argc > 0 ? argv[0] : janet_wrap_nil(); } return janet_wrap_integer(result); #elif defined(JANET_ILLUMOS) - (void) dflt; long result = sysconf(_SC_NPROCESSORS_CONF); if (result < 0) { - return dflt; + 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 dflt; + return argc > 0 ? argv[0] : janet_wrap_nil(); #endif } @@ -360,6 +380,8 @@ static EnvBlock os_execute_env(int32_t argc, const Janet *argv) { 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); @@ -1207,7 +1229,7 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, JanetExecuteMode mode) { 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 (is_spawn && janet_keyeq(maybe_stderr, "out")) { + } 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); @@ -1293,6 +1315,7 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, JanetExecuteMode mode) { } 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 */ @@ -1304,6 +1327,7 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, JanetExecuteMode mode) { &startupInfo, &processInfo)) { cp_failed = 1; + cp_error_code = GetLastError(); } if (pipe_in != JANET_HANDLE_NONE) CloseHandle(pipe_in); @@ -1313,7 +1337,25 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, JanetExecuteMode mode) { os_execute_cleanup(envp, NULL); if (cp_failed) { - janet_panic("failed to create process"); + 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, (uint32_t) 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; @@ -1339,6 +1381,9 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, JanetExecuteMode mode) { /* exec mode */ if (mode == JANET_EXECUTE_EXEC) { int status; +#ifdef JANET_PLAN9 + status = exec(cargv[0], cargv); +#else if (!use_environ) { environ = envp; } @@ -1349,9 +1394,11 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, JanetExecuteMode mode) { 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 */ @@ -1420,6 +1467,8 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, JanetExecuteMode mode) { } #endif +#endif +#ifndef JANET_NO_SPAWN JanetProc *proc = janet_abstract(&ProcAT, sizeof(JanetProc)); proc->return_code = -1; #ifdef JANET_WINDOWS @@ -1457,6 +1506,7 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, JanetExecuteMode mode) { return os_proc_wait_impl(proc); #endif } +#endif } JANET_CORE_FN(os_execute, @@ -1517,7 +1567,7 @@ JANET_CORE_FN(os_posix_exec, 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 only).") { + "Not supported on all systems (POSIX and Plan 9 only).") { janet_sandbox_assert(JANET_SANDBOX_SUBPROCESS); janet_fixarity(argc, 0); (void) argv; @@ -1525,9 +1575,13 @@ JANET_CORE_FN(os_posix_fork, 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)); } @@ -1548,8 +1602,9 @@ JANET_CORE_FN(os_posix_chroot, "Not supported on all systems (POSIX only).") { janet_sandbox_assert(JANET_SANDBOX_CHROOT); janet_fixarity(argc, 1); -#ifdef JANET_WINDOWS - janet_panic("not supported on Windows"); +#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; @@ -1587,7 +1642,14 @@ JANET_CORE_FN(os_shell, ? janet_getcstring(argv, 0) : NULL; #ifdef JANET_EV - janet_ev_threaded_await(os_shell_subr, 0, argc, cmd ? strdup(cmd) : NULL); + char *cmd_copy = NULL; + if (cmd != NULL) { + size_t cmdlen = strlen(cmd); + cmd_copy = janet_malloc(cmdlen + 1); + memcpy(cmd_copy, cmd, cmdlen); + cmd_copy[cmdlen] = '\0'; + } + janet_ev_threaded_await(os_shell_subr, 0, argc, cmd_copy); #else int stat = system(cmd); return argc @@ -1598,6 +1660,7 @@ JANET_CORE_FN(os_shell, #endif /* JANET_NO_PROCESSES */ +#ifndef JANET_PLAN9 JANET_CORE_FN(os_environ, "(os/environ)", "Get a copy of the OS environment table.") { @@ -1629,6 +1692,7 @@ JANET_CORE_FN(os_environ, janet_unlock_environ(); return janet_wrap_table(t); } +#endif JANET_CORE_FN(os_getenv, "(os/getenv variable &opt dflt)", @@ -1653,6 +1717,9 @@ JANET_CORE_FN(os_setenv, #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) @@ -1825,6 +1892,8 @@ static struct tm *time_to_tm(const Janet *argv, int32_t argc, int32_t n, struct _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); @@ -1834,6 +1903,8 @@ static struct tm *time_to_tm(const Janet *argv, int32_t argc, int32_t n, struct #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 @@ -1844,9 +1915,8 @@ static struct tm *time_to_tm(const Janet *argv, int32_t argc, int32_t n, struct 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. " - "Returns a struct with following key values. Note that all numbers are 0-indexed. " "Date is given in UTC unless `local` is truthy, in which case the date is formatted for " - "the local timezone.\n\n" + "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" @@ -1855,7 +1925,9 @@ JANET_CORE_FN(os_date, "* :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") { + "* :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; @@ -1873,14 +1945,15 @@ JANET_CORE_FN(os_date, return janet_wrap_struct(janet_struct_end(st)); } -#define SIZETIMEFMT 250 +#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.") { + "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" */ @@ -1888,6 +1961,9 @@ JANET_CORE_FN(os_strftime, 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); } @@ -1897,7 +1973,7 @@ JANET_CORE_FN(os_strftime, struct tm t_infos; struct tm *t_info = time_to_tm(argv, argc, 1, &t_infos); char buf[SIZETIMEFMT]; - (void)strftime(buf, SIZETIMEFMT, fmt, t_info); + (void)strftime(buf, sizeof(buf), fmt, t_info); return janet_cstringv(buf); } @@ -1905,7 +1981,7 @@ 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(entry, janet_ckeywordv("dst")); + 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")); @@ -1929,7 +2005,7 @@ 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(entry, janet_ckeywordv(field)); + 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)); @@ -2008,6 +2084,7 @@ JANET_CORE_FN(os_mktime, #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. " @@ -2044,19 +2121,20 @@ JANET_CORE_FN(os_setlocale, 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.") { + "creates a hard link. Does not work on Windows or Plan 9.") { janet_sandbox_assert(JANET_SANDBOX_FS_WRITE); janet_arity(argc, 2, 3); -#ifdef JANET_WINDOWS +#if defined(JANET_WINDOWS) || defined(JANET_PLAN9) (void) argc; (void) argv; - janet_panic("not supported on Windows"); + janet_panic("not supported on Windows or Plan 9"); #else const char *oldpath = janet_getcstring(argv, 0); const char *newpath = janet_getcstring(argv, 1); @@ -2071,10 +2149,10 @@ JANET_CORE_FN(os_symlink, "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); -#ifdef JANET_WINDOWS +#if defined(JANET_WINDOWS) || defined(JANET_PLAN9) (void) argc; (void) argv; - janet_panic("not supported on Windows"); + janet_panic("not supported on Windows or Plan 9"); #else const char *oldpath = janet_getcstring(argv, 0); const char *newpath = janet_getcstring(argv, 1); @@ -2112,6 +2190,8 @@ JANET_CORE_FN(os_rmdir, 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 @@ -2178,7 +2258,7 @@ JANET_CORE_FN(os_readlink, (void) argv; janet_panic("not supported on Windows"); #else - static char buffer[PATH_MAX]; + 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) @@ -2238,11 +2318,13 @@ 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); } @@ -2407,6 +2489,9 @@ static Janet os_stat_or_lstat(int do_lstat, int32_t argc, Janet *argv) { #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) { @@ -2437,8 +2522,9 @@ static Janet os_stat_or_lstat(int do_lstat, int32_t argc, Janet *argv) { 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" + "Gets information about a file or directory. Returns a table unless the second argument is a keyword, " + "in which case it returns only that field/value 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" @@ -2467,9 +2553,13 @@ JANET_CORE_FN(os_chmod, "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.") { + "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)); @@ -2478,6 +2568,7 @@ JANET_CORE_FN(os_chmod, #endif if (-1 == res) janet_panicf("%s: %s", janet_strerror(errno), path); return janet_wrap_nil(); +#endif } #ifndef JANET_NO_UMASK @@ -2510,7 +2601,7 @@ JANET_CORE_FN(os_dir, char pattern[MAX_PATH + 1]; if (strlen(dir) > (sizeof(pattern) - 3)) janet_panicf("path too long: %s", dir); - sprintf(pattern, "%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 { @@ -2576,7 +2667,15 @@ JANET_CORE_FN(os_realpath, #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 } @@ -2620,10 +2719,11 @@ JANET_CORE_FN(os_open, " * :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" - " * :a - append to a file (O\\_APPEND)\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" @@ -2633,19 +2733,24 @@ JANET_CORE_FN(os_open, " * :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 flagsAndAttributes = FILE_FLAG_OVERLAPPED; + DWORD fileFlags = FILE_FLAG_OVERLAPPED; + DWORD fileAttributes = 0; /* We map unix-like open flags to the creationDisp parameter */ int creatUnix = 0; #define OCREAT 1 @@ -2665,6 +2770,11 @@ JANET_CORE_FN(os_open, 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); @@ -2687,22 +2797,29 @@ JANET_CORE_FN(os_open, shareMode |= FILE_SHARE_WRITE; break; case 'H': - flagsAndAttributes |= FILE_ATTRIBUTE_HIDDEN; + fileAttributes |= FILE_ATTRIBUTE_HIDDEN; break; case 'O': - flagsAndAttributes |= FILE_ATTRIBUTE_READONLY; + fileAttributes |= FILE_ATTRIBUTE_READONLY; break; case 'F': - flagsAndAttributes |= FILE_ATTRIBUTE_OFFLINE; + fileAttributes |= FILE_ATTRIBUTE_OFFLINE; break; case 'T': - flagsAndAttributes |= FILE_ATTRIBUTE_TEMPORARY; + fileAttributes |= FILE_ATTRIBUTE_TEMPORARY; break; case 'd': - flagsAndAttributes |= FILE_FLAG_DELETE_ON_CLOSE; + fileFlags |= FILE_FLAG_DELETE_ON_CLOSE; break; case 'b': - flagsAndAttributes |= FILE_FLAG_NO_BUFFERING; + 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 @@ -2728,7 +2845,16 @@ JANET_CORE_FN(os_open, creationDisp = TRUNCATE_EXISTING; break; } - fd = CreateFileA(path, desiredAccess, shareMode, NULL, creationDisp, flagsAndAttributes, NULL); + 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; @@ -2772,6 +2898,10 @@ JANET_CORE_FN(os_open, 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 */ @@ -2788,7 +2918,7 @@ JANET_CORE_FN(os_open, } while (fd == -1 && errno == EINTR); if (fd == -1) janet_panicv(janet_ev_lasterr()); #endif - return janet_wrap_abstract(janet_stream(fd, stream_flags, NULL)); + return janet_wrap_abstract(janet_stream(fd, disable_stream_mode ? 0 : stream_flags, NULL)); } JANET_CORE_FN(os_pipe, @@ -2856,10 +2986,14 @@ void janet_lib_os(JanetTable *env) { 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), @@ -2871,7 +3005,6 @@ void janet_lib_os(JanetTable *env) { JANET_CORE_REG("os/touch", os_touch), JANET_CORE_REG("os/realpath", os_realpath), JANET_CORE_REG("os/cd", os_cd), - JANET_CORE_REG("os/posix-chroot", os_posix_chroot), #ifndef JANET_NO_UMASK JANET_CORE_REG("os/umask", os_umask), #endif @@ -2896,6 +3029,7 @@ void janet_lib_os(JanetTable *env) { 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), diff --git a/src/core/parse.c b/src/core/parse.c index 5b5ffff8..ff6a5978 100644 --- a/src/core/parse.c +++ b/src/core/parse.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -105,15 +105,6 @@ static int to_hex(uint8_t c) { } } -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; -}; /* Define a stack on the main parser struct */ #define DEF_PARSER_STACK(NAME, T, STACK, STACKCOUNT, STACKCAP) \ diff --git a/src/core/peg.c b/src/core/peg.c index 454cc802..79fee92e 100644 --- a/src/core/peg.c +++ b/src/core/peg.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -194,6 +194,41 @@ tail: 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; @@ -622,6 +657,7 @@ tail: } case RULE_REPLACE: + case RULE_MATCHSPLICE: case RULE_MATCHTIME: { uint32_t tag = rule[3]; int oldmode = s->mode; @@ -662,8 +698,17 @@ tail: break; } cap_load_keept(s, cs); - if (rule[0] == RULE_MATCHTIME && !janet_truthy(cap)) return NULL; - pushcap(s, cap, tag); + 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; } @@ -1235,6 +1280,14 @@ static void spec_constant(Builder *b, int32_t argc, const Janet *argv) { 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); @@ -1244,7 +1297,7 @@ static void spec_replace(Builder *b, int32_t argc, const Janet *argv) { emit_3(r, RULE_REPLACE, subrule, constant, tag); } -static void spec_matchtime(Builder *b, int32_t argc, const Janet *argv) { +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]); @@ -1255,7 +1308,15 @@ static void spec_matchtime(Builder *b, int32_t argc, const Janet *argv) { } uint32_t tag = (argc == 3) ? emit_tag(b, argv[2]) : 0; uint32_t cindex = emit_constant(b, fun); - emit_3(r, RULE_MATCHTIME, subrule, cindex, tag); + 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) { @@ -1331,6 +1392,7 @@ static const SpecialPair peg_specials[] = { {"<-", spec_capture}, {">", spec_look}, {"?", spec_opt}, + {"??", spec_debug}, {"accumulate", spec_accumulate}, {"any", spec_any}, {"argument", spec_argument}, @@ -1341,9 +1403,11 @@ static const SpecialPair peg_specials[] = { {"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}, @@ -1566,6 +1630,8 @@ static size_t size_padded(size_t offset, size_t size) { return x - (x % size); } +#define OVERFLOW_CHECK(n) do { if (i > blen - (n)) goto bad; } while (0) /* overflow */ + static void *peg_unmarshal(JanetMarshalContext *ctx) { size_t bytecode_len = janet_unmarshal_size(ctx); uint32_t num_constants = (uint32_t) janet_unmarshal_int(ctx); @@ -1597,7 +1663,7 @@ static void *peg_unmarshal(JanetMarshalContext *ctx) { /* After here, no panics except for the bad: label. */ /* Keep track at each index if an instruction was - * reference (0x01) or is in a main bytecode position + * 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 @@ -1618,8 +1684,13 @@ static void *peg_unmarshal(JanetMarshalContext *ctx) { op_flags[i] |= 0x02; switch (instr) { case RULE_LITERAL: + OVERFLOW_CHECK(1); /* We only read rule[1] */ i += 2 + ((rule[1] + 3) >> 2); break; + case RULE_DEBUG: + /* [0 words] */ + i += 1; + break; case RULE_NCHAR: case RULE_NOTNCHAR: case RULE_RANGE: @@ -1640,6 +1711,7 @@ static void *peg_unmarshal(JanetMarshalContext *ctx) { break; case RULE_LOOK: /* [offset, rule] */ + OVERFLOW_CHECK(3); if (rule[2] >= blen) goto bad; op_flags[rule[2]] |= 0x1; i += 3; @@ -1648,7 +1720,9 @@ static void *peg_unmarshal(JanetMarshalContext *ctx) { case RULE_SEQUENCE: /* [len, rules...] */ { + OVERFLOW_CHECK(2); uint32_t len = rule[1]; + OVERFLOW_CHECK(2 + len); for (uint32_t j = 0; j < len; j++) { if (rule[2 + j] >= blen) goto bad; op_flags[rule[2 + j]] |= 0x1; @@ -1660,6 +1734,7 @@ static void *peg_unmarshal(JanetMarshalContext *ctx) { case RULE_IFNOT: case RULE_LENPREFIX: /* [rule_a, rule_b (b if not a)] */ + OVERFLOW_CHECK(3); if (rule[1] >= blen) goto bad; if (rule[2] >= blen) goto bad; op_flags[rule[1]] |= 0x01; @@ -1668,6 +1743,7 @@ static void *peg_unmarshal(JanetMarshalContext *ctx) { break; case RULE_BETWEEN: /* [lo, hi, rule] */ + OVERFLOW_CHECK(4); if (rule[3] >= blen) goto bad; op_flags[rule[3]] |= 0x01; i += 4; @@ -1683,11 +1759,13 @@ static void *peg_unmarshal(JanetMarshalContext *ctx) { break; case RULE_CONSTANT: /* [constant, tag] */ + OVERFLOW_CHECK(3); if (rule[1] >= clen) goto bad; i += 3; break; case RULE_CAPTURE_NUM: /* [rule, base, tag] */ + OVERFLOW_CHECK(4); if (rule[1] >= blen) goto bad; op_flags[rule[1]] |= 0x01; i += 4; @@ -1697,13 +1775,16 @@ static void *peg_unmarshal(JanetMarshalContext *ctx) { case RULE_CAPTURE: case RULE_UNREF: /* [rule, tag] */ + OVERFLOW_CHECK(3); 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] */ + OVERFLOW_CHECK(4); if (rule[1] >= blen) goto bad; if (rule[2] >= clen) goto bad; op_flags[rule[1]] |= 0x01; @@ -1713,6 +1794,7 @@ static void *peg_unmarshal(JanetMarshalContext *ctx) { case RULE_TIL: case RULE_SPLIT: /* [rule, rule] */ + OVERFLOW_CHECK(3); if (rule[1] >= blen) goto bad; if (rule[2] >= blen) goto bad; op_flags[rule[1]] |= 0x01; @@ -1726,17 +1808,20 @@ static void *peg_unmarshal(JanetMarshalContext *ctx) { case RULE_TO: case RULE_THRU: /* [rule] */ + OVERFLOW_CHECK(2); if (rule[1] >= blen) goto bad; op_flags[rule[1]] |= 0x01; i += 2; break; case RULE_READINT: /* [ width | (endianness << 5) | (signedness << 6), tag ] */ + OVERFLOW_CHECK(3); if (rule[1] > JANET_MAX_READINT_WIDTH) goto bad; i += 3; break; case RULE_NTH: /* [nth, rule, tag] */ + OVERFLOW_CHECK(4); if (rule[2] >= blen) goto bad; op_flags[rule[2]] |= 0x01; i += 4; @@ -1766,6 +1851,8 @@ bad: janet_panic("invalid peg bytecode"); } +#undef OVERFLOW_CHECK + static int cfun_peg_getter(JanetAbstract a, Janet key, Janet *out); static Janet peg_next(void *p, Janet key); @@ -1834,8 +1921,8 @@ static JanetPeg *compile_peg(Janet x) { 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. Will also use `(dyn :peg-grammar)` to supplement " - "the grammar of the peg for otherwise undefined peg keywords.") { + "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); diff --git a/src/core/pp.c b/src/core/pp.c index 3b000f41..d70a3491 100644 --- a/src/core/pp.c +++ b/src/core/pp.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -72,7 +72,7 @@ static int count_dig10(int32_t x) { } } -static void integer_to_string_b(JanetBuffer *buffer, int32_t x) { +static int32_t 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; @@ -80,7 +80,7 @@ static void integer_to_string_b(JanetBuffer *buffer, int32_t x) { if (x == 0) { buf[0] = '0'; buffer->count++; - return; + return 1; } if (x > 0) { x = -x; @@ -96,6 +96,7 @@ static void integer_to_string_b(JanetBuffer *buffer, int32_t x) { x /= 10; } buffer->count += len + neg; + return len + neg; } #define HEX(i) (((uint8_t *) janet_base64)[(i)]) @@ -134,43 +135,55 @@ static void string_description_b(JanetBuffer *buffer, const char *title, void *p #undef POINTSIZE } -static void janet_escape_string_impl(JanetBuffer *buffer, const uint8_t *str, int32_t len) { +static int janet_escape_string_impl(JanetBuffer *buffer, const uint8_t *str, int32_t len) { janet_buffer_push_u8(buffer, '"'); + int align = 1; 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); + align += 2; break; case '\n': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\n", 2); + align += 2; break; case '\r': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\r", 2); + align += 2; break; case '\0': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\0", 2); + align += 2; break; case '\f': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\f", 2); + align += 2; break; case '\v': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\v", 2); + align += 2; break; case '\a': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\a", 2); + align += 2; break; case '\b': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\b", 2); + align += 2; break; case 27: janet_buffer_push_bytes(buffer, (const uint8_t *)"\\e", 2); + align += 2; break; case '\\': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\\\", 2); + align += 2; break; case '\t': janet_buffer_push_bytes(buffer, (const uint8_t *)"\\t", 2); + align += 2; break; default: if (c < 32 || c > 126) { @@ -180,13 +193,16 @@ static void janet_escape_string_impl(JanetBuffer *buffer, const uint8_t *str, in buf[2] = janet_base64[(c >> 4) & 0xF]; buf[3] = janet_base64[c & 0xF]; janet_buffer_push_bytes(buffer, buf, 4); + align += 4; } else { janet_buffer_push_u8(buffer, c); + align++; } break; } } janet_buffer_push_u8(buffer, '"'); + return align + 1; } static void janet_escape_string_b(JanetBuffer *buffer, const uint8_t *str) { @@ -358,9 +374,12 @@ const uint8_t *janet_to_string(Janet x) { struct pretty { JanetBuffer *buffer; int depth; - int indent; + int width; + int align; + int leaf_align; int flags; int32_t bufstartlen; + int32_t lookback_barrier; int32_t *keysort_buffer; int32_t keysort_capacity; int32_t keysort_start; @@ -450,14 +469,76 @@ static int print_jdn_one(struct pretty *S, Janet x, int depth) { return 0; } -static void print_newline(struct pretty *S, int just_a_space) { +static void backtrack_newlines(const struct pretty *S) { + if (S->flags & JANET_PRETTY_ONELINE || S->buffer->count <= 0) + return; + switch (S->buffer->data[S->buffer->count - 1]) { + case ')': + case '}': + case ']': + break; + default: + return; + } + int32_t removed = 0; + int32_t old_count = S->buffer->count; + int32_t offset = old_count; + int32_t b0 = S->lookback_barrier; + int32_t columns = S->width; + int32_t align = 0; + while (--offset >= b0) { + const char *s = (const char *)S->buffer->data + offset; + if (*s == '\n') { + if (align < S->leaf_align) { + break; + } + columns += align; + removed += align; + align = 0; + } else if (*s == ' ') { + align++; + } else { + align = 0; + /* Don't count color sequences: \x1B(0|3\d)m */ + if (S->flags & JANET_PRETTY_COLOR && *s == 'm') { + if (offset >= (3 + b0) && strncmp("\x1B[0m", s - 3, 4) == 0) { + offset -= 3; + columns++; + } else if (offset >= (4 + b0) && strncmp("\x1B[3", s - 4, 3) == 0) { + offset -= 4; + columns++; + } + } + } + if (--columns <= 0) { + return; + } + } + offset++; /* Don't mess with the last newline we found */ + janet_assert(offset >= b0, "bad buffer index"); + S->buffer->count -= removed; + for (int32_t i = offset; i < S->buffer->count; i++) { + if (S->buffer->data[offset] == '\n') { + S->buffer->data[i] = ' '; + while (S->buffer->data[++offset] == ' ') { + janet_assert(offset < old_count, "bad replacement of newline"); + } + } else { + S->buffer->data[i] = S->buffer->data[offset++]; + } + } +} + +static void print_newline(struct pretty *S, int align) { int i; - if (just_a_space || (S->flags & JANET_PRETTY_ONELINE)) { + if (S->flags & JANET_PRETTY_ONELINE) { janet_buffer_push_u8(S->buffer, ' '); return; } + backtrack_newlines(S); janet_buffer_push_u8(S->buffer, '\n'); - for (i = 0; i < S->indent; i++) { + S->leaf_align = S->align = align; + for (i = 0; i < S->align; i++) { janet_buffer_push_u8(S->buffer, ' '); } } @@ -484,13 +565,12 @@ static const char *janet_pretty_colors[] = { "\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) { +static void janet_pretty_one(struct pretty *S, Janet x) { /* Add to seen */ switch (janet_type(x)) { case JANET_NIL: @@ -505,7 +585,7 @@ static void janet_pretty_one(struct pretty *S, Janet x, int is_dict_value) { janet_buffer_push_cstring(S->buffer, janet_cycle_color); } janet_buffer_push_cstring(S->buffer, "buffer, janet_unwrap_integer(seenid)); + S->align += 8 + integer_to_string_b(S->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"); @@ -527,9 +607,12 @@ static void janet_pretty_one(struct pretty *S, Janet x, int is_dict_value) { 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); + /* Use start len to print to self better */ + S->align += 1 + janet_escape_string_impl(S->buffer, S->buffer->data, S->bufstartlen); } else { + S->align -= S->buffer->count; janet_description_b(S->buffer, x); + S->align += S->buffer->count; } if (color && (S->flags & JANET_PRETTY_COLOR)) { janet_buffer_push_cstring(S->buffer, "\x1B[0m"); @@ -546,35 +629,35 @@ static void janet_pretty_one(struct pretty *S, Janet x, int is_dict_value) { const char *startstr = isarray ? "@[" : hasbrackets ? "[" : "("; const char endchar = isarray ? ']' : hasbrackets ? ']' : ')'; janet_buffer_push_cstring(S->buffer, startstr); + S->align += strlen(startstr); + const int align = S->leaf_align = S->align; S->depth--; - S->indent += 2; if (S->depth == 0) { janet_buffer_push_cstring(S->buffer, "..."); + S->align += 3; } 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); + if (i) print_newline(S, align); + janet_pretty_one(S, arr[i]); } - print_newline(S, 0); + print_newline(S, align); 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); + S->align += 3; + for (i = len - 3; i < len; i++) { + print_newline(S, align); + janet_pretty_one(S, arr[i]); } } else { for (i = 0; i < len; i++) { - if (i) print_newline(S, len < JANET_PRETTY_IND_ONELINE); - janet_pretty_one(S, arr[i], 0); + if (i) print_newline(S, align); + janet_pretty_one(S, arr[i]); } } } - S->indent -= 2; S->depth++; janet_buffer_push_u8(S->buffer, endchar); + S->align++; break; } case JANET_STRUCT: @@ -585,6 +668,7 @@ static void janet_pretty_one(struct pretty *S, Janet x, int is_dict_value) { if (istable) { JanetTable *t = janet_unwrap_table(x); JanetTable *proto = t->proto; + S->align++; janet_buffer_push_cstring(S->buffer, "@"); if (NULL != proto) { Janet name = janet_table_get(proto, janet_ckeywordv("_name")); @@ -595,6 +679,7 @@ static void janet_pretty_one(struct pretty *S, Janet x, int is_dict_value) { janet_buffer_push_cstring(S->buffer, janet_class_color); } janet_buffer_push_bytes(S->buffer, n, len); + S->align += len; if (S->flags & JANET_PRETTY_COLOR) { janet_buffer_push_cstring(S->buffer, "\x1B[0m"); } @@ -612,73 +697,99 @@ static void janet_pretty_one(struct pretty *S, Janet x, int is_dict_value) { janet_buffer_push_cstring(S->buffer, janet_class_color); } janet_buffer_push_bytes(S->buffer, n, len); + S->align += len; if (S->flags & JANET_PRETTY_COLOR) { janet_buffer_push_cstring(S->buffer, "\x1B[0m"); } } } } - janet_buffer_push_cstring(S->buffer, "{"); + janet_buffer_push_u8(S->buffer, '{'); + const int align = S->leaf_align = ++S->align; S->depth--; - S->indent += 2; if (S->depth == 0) { janet_buffer_push_cstring(S->buffer, "..."); + S->align += 3; } else { - int32_t i = 0, len = 0, cap = 0; + 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; - - /* Ensure buffer is large enough to sort keys. */ int truncated = 0; - 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); + /* 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; } - S->keysort_buffer = janet_srealloc(S->keysort_buffer, sizeof(int32_t) * S->keysort_capacity); - if (NULL == S->keysort_buffer) { - JANET_OUT_OF_MEMORY; + 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, align); + janet_pretty_one(S, kvs[j].key); + janet_buffer_push_u8(S->buffer, ' '); + S->align++; + janet_pretty_one(S, kvs[j].value); + j++; } - } + if (truncated) { + print_newline(S, align); + janet_buffer_push_cstring(S->buffer, "..."); + S->align += 3; + } + } else { + /* Sorted keys dictionaries */ - 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; - } + /* 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; + } - for (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 (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; + } + } - if (truncated) { - print_newline(S, 0); - janet_buffer_push_cstring(S->buffer, "..."); - } + 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, align); + int32_t j = S->keysort_buffer[i + ks_start]; + janet_pretty_one(S, kvs[j].key); + janet_buffer_push_u8(S->buffer, ' '); + S->align++; + janet_pretty_one(S, kvs[j].value); + } + + if (truncated) { + print_newline(S, align); + janet_buffer_push_cstring(S->buffer, "..."); + S->align += 3; + } + + } S->keysort_start = ks_start; } - S->indent -= 2; S->depth++; janet_buffer_push_u8(S->buffer, '}'); + S->align++; break; } } @@ -687,21 +798,27 @@ static void janet_pretty_one(struct pretty *S, Janet x, int is_dict_value) { return; } -static JanetBuffer *janet_pretty_(JanetBuffer *buffer, int depth, int flags, Janet x, int32_t startlen) { +#define JANET_COLUMNS 80 + +static JanetBuffer *janet_pretty_(JanetBuffer *buffer, int depth, int width, + int flags, Janet x, int32_t startlen, int32_t lookback_barrier) { struct pretty S; if (NULL == buffer) { buffer = janet_buffer(0); } S.buffer = buffer; S.depth = depth; - S.indent = 0; + S.width = width; + S.align = 0; S.flags = flags; S.bufstartlen = startlen; + S.lookback_barrier = lookback_barrier; 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_pretty_one(&S, x); + backtrack_newlines(&S); janet_table_deinit(&S.seen); return S.buffer; } @@ -709,19 +826,21 @@ static JanetBuffer *janet_pretty_(JanetBuffer *buffer, int depth, int flags, Jan /* 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); + return janet_pretty_(buffer, depth, JANET_COLUMNS, flags, + x, buffer ? buffer->count : 0, buffer ? buffer->count : 0); } -static JanetBuffer *janet_jdn_(JanetBuffer *buffer, int depth, Janet x, int32_t startlen) { +static JanetBuffer *janet_jdn_(JanetBuffer *buffer, int depth, Janet x, int32_t startlen, int32_t lookback_barrier) { struct pretty S; if (NULL == buffer) { buffer = janet_buffer(0); } S.buffer = buffer; S.depth = depth; - S.indent = 0; + S.align = 0; S.flags = 0; S.bufstartlen = startlen; + S.lookback_barrier = lookback_barrier; S.keysort_capacity = 0; S.keysort_buffer = NULL; S.keysort_start = 0; @@ -735,7 +854,7 @@ static JanetBuffer *janet_jdn_(JanetBuffer *buffer, int depth, Janet x, int32_t } JanetBuffer *janet_jdn(JanetBuffer *buffer, int depth, Janet x) { - return janet_jdn_(buffer, depth, x, buffer ? buffer->count : 0); + return janet_jdn_(buffer, depth, x, buffer ? buffer->count : 0, buffer ? buffer->count : 0); } static const char *typestr(Janet x) { @@ -897,7 +1016,7 @@ void janet_formatbv(JanetBuffer *b, const char *format, va_list args) { case 's': case 'S': { const char *str = va_arg(args, const char *); - int32_t len = c[-1] == 's' + int32_t len = (c[-1] == 's') ? (int32_t) strlen(str) : janet_string_length((JanetString) str); if (form[2] == '\0') @@ -941,18 +1060,26 @@ void janet_formatbv(JanetBuffer *b, const char *format, va_list args) { 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 columns = atoi(width); + if (columns == 0) { + columns = JANET_COLUMNS; + } else if (columns < 0) { + has_oneline = 1; + } 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); + janet_pretty_(b, depth, columns, flags, + va_arg(args, Janet), startlen, b->count); break; } case 'j': { int depth = atoi(precision); - if (depth < 1) + if (depth < 1) { depth = JANET_RECURSION_GUARD; - janet_jdn_(b, depth, va_arg(args, Janet), startlen); + } + janet_jdn_(b, depth, va_arg(args, Janet), startlen, b->count); break; } default: { @@ -1023,10 +1150,20 @@ void janet_buffer_format( char form[MAX_FORMAT], item[MAX_ITEM]; char width[3], precision[3]; int nb = 0; /* number of bytes in added item */ - if (++arg >= argc) - janet_panic("not enough values for format"); +#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)); @@ -1093,18 +1230,24 @@ void janet_buffer_format( 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 columns = atoi(width); + if (columns == 0) + columns = JANET_COLUMNS; + else if (columns < 0) + has_oneline = 1; 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); + janet_pretty_(b, depth, columns, flags, + argv[arg], startlen, b->count); break; } case 'j': { int depth = atoi(precision); if (depth < 1) depth = JANET_RECURSION_GUARD; - janet_jdn_(b, depth, argv[arg], startlen); + janet_jdn_(b, depth, argv[arg], startlen, b->count); break; } default: { diff --git a/src/core/regalloc.c b/src/core/regalloc.c index ef8768eb..2b08b2a4 100644 --- a/src/core/regalloc.c +++ b/src/core/regalloc.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/core/regalloc.h b/src/core/regalloc.h index ca6c833e..7291d9fc 100644 --- a/src/core/regalloc.h +++ b/src/core/regalloc.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/core/run.c b/src/core/run.c index b6a78847..2846f818 100644 --- a/src/core/run.c +++ b/src/core/run.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -60,7 +60,6 @@ int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char done = 1; } } else { - ret = janet_wrap_string(cres.error); int32_t line = (int32_t) parser->line; int32_t col = (int32_t) parser->column; if ((cres.error_mapping.line > 0) && @@ -68,13 +67,17 @@ int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char 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:%d:%d: compile error", sourcePath, - line, col); + janet_eprintf("%s", (const char *)ctx); janet_stacktrace_ext(cres.macrofiber, ret, ""); } else { - janet_eprintf("%s:%d:%d: compile error: %s\n", sourcePath, - line, col, (const char *)cres.error); + janet_eprintf("%s\n", (const char *)errstr); } errflags |= JANET_DO_ERROR_COMPILE; done = 1; @@ -89,12 +92,14 @@ int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char done = 1; break; case JANET_PARSE_ERROR: { - const char *e = janet_parser_error(parser); errflags |= JANET_DO_ERROR_PARSE; - ret = janet_cstringv(e); int32_t line = (int32_t) parser->line; int32_t col = (int32_t) parser->column; - janet_eprintf("%s:%d:%d: parse error: %s\n", sourcePath, line, col, e); + 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; } @@ -122,7 +127,8 @@ int janet_dobytes(JanetTable *env, const uint8_t *bytes, int32_t len, const char janet_loop(); if (fiber) { janet_gcunroot(janet_wrap_fiber(fiber)); - ret = fiber->last_value; + if (!errflags) + ret = fiber->last_value; } } #endif diff --git a/src/core/specials.c b/src/core/specials.c index 1a17257e..1f154d8b 100644 --- a/src/core/specials.c +++ b/src/core/specials.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -29,6 +29,30 @@ #include "emit.h" #endif +static int bad_16bit_jump(int32_t lab1, int32_t lab2) { + if (lab2 - lab1 > INT16_MAX) return 1; + if (lab2 - lab1 < INT16_MIN) return 1; + return 0; +} + +static void check_16bit_jump(JanetCompiler *c, int32_t lab1, int32_t lab2) { + if (bad_16bit_jump(lab1, lab2)) { + janetc_cerror(c, "bad 16-bit jump, too large"); + } +} + +static int bad_24bit_jump(int32_t lab1, int32_t lab2) { + if (lab2 - lab1 > 0xFFFFFF) return 1; + if (lab2 - lab1 < -0x1000000) return 1; + return 0; +} + +static void check_24bit_jump(JanetCompiler *c, int32_t lab1, int32_t lab2) { + if (bad_24bit_jump(lab1, lab2)) { + janetc_cerror(c, "bad 24-bit jump, too large"); + } +} + static JanetSlot janetc_quote(JanetFopts opts, int32_t argn, const Janet *argv) { if (argn != 1) { janetc_cerror(opts.compiler, "expected 1 argument to quote"); @@ -126,7 +150,7 @@ static JanetSlot janetc_quasiquote(JanetFopts opts, int32_t argn, const Janet *a janetc_cerror(opts.compiler, "expected 1 argument to quasiquote"); return janetc_cslot(janet_wrap_nil()); } - return quasiquote(opts, argv[0], JANET_RECURSION_GUARD, 0); + return quasiquote(opts, argv[0], opts.compiler->recursion_guard, 0); } static JanetSlot janetc_unquote(JanetFopts opts, int32_t argn, const Janet *argv) { @@ -147,6 +171,10 @@ static int destructure(JanetCompiler *c, JanetSlot s, JanetTable *attr), JanetTable *attr) { + if (c->recursion_guard <= 0) { + janetc_error(c, janet_cstring("C stack recursed too deeply")); + return 1; + } switch (janet_type(left)) { default: janetc_error(c, janet_formatc("unexpected type in destructuring, got %v", left)); @@ -209,6 +237,8 @@ static int destructure(JanetCompiler *c, int32_t label_loop_exit = janet_v_count(c->buffer); /* avoid shifting negative numbers */ + check_16bit_jump(c, label_loop_cond_jump, label_loop_exit); + check_24bit_jump(c, label_loop_start, label_loop_loop); 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; @@ -229,8 +259,10 @@ static int destructure(JanetCompiler *c, JanetSlot k = janetc_cslot(janet_wrap_integer(i)); janetc_emit_sss(c, JOP_IN, nextright, right, k, 1); } + c->recursion_guard--; if (destructure(c, subval, nextright, leaf, attr)) janetc_freeslot(c, nextright); + c->recursion_guard++; } } return 1; @@ -244,8 +276,10 @@ static int destructure(JanetCompiler *c, 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); + c->recursion_guard--; if (destructure(c, kvs[i].value, nextright, leaf, attr)) janetc_freeslot(c, nextright); + c->recursion_guard++; } } return 1; @@ -307,14 +341,14 @@ static JanetSlot janetc_varset(JanetFopts opts, int32_t argn, const Janet *argv) /* 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; - JanetTable *tab = janet_table(2); - const char *binding_name = janet_type(argv[0]) == JANET_SYMBOL - ? ((const char *)janet_unwrap_symbol(argv[0])) - : ""; 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)) { @@ -344,7 +378,10 @@ typedef struct SlotHeadPair { } SlotHeadPair; SlotHeadPair *dohead_destructure(JanetCompiler *c, SlotHeadPair *into, JanetFopts opts, Janet lhs, Janet rhs) { - + if (c->recursion_guard <= 0) { + janetc_error(c, janet_cstring("C stack recursed too deeply")); + return NULL; + } /* 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); @@ -362,6 +399,23 @@ SlotHeadPair *dohead_destructure(JanetCompiler *c, SlotHeadPair *into, JanetFopt 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; @@ -369,10 +423,12 @@ SlotHeadPair *dohead_destructure(JanetCompiler *c, SlotHeadPair *into, JanetFopt break; } } - if (!found_amp) { + 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]; + c->recursion_guard--; into = dohead_destructure(c, into, subopts, view_lhs.items[i], sub_rhs); + c->recursion_guard++; } return into; } @@ -387,7 +443,7 @@ SlotHeadPair *dohead_destructure(JanetCompiler *c, SlotHeadPair *into, JanetFopt } /* Def or var a symbol in a local scope */ -static int namelocal(JanetCompiler *c, const uint8_t *head, int32_t flags, JanetSlot ret) { +static int namelocal(JanetCompiler *c, const uint8_t *head, int32_t flags, JanetSlot ret, uint32_t def_flags) { int isUnnamedRegister = !(ret.flags & JANET_SLOT_NAMED) && ret.index > 0 && ret.envindex >= 0; @@ -408,7 +464,10 @@ static int namelocal(JanetCompiler *c, const uint8_t *head, int32_t flags, Janet ret = localslot; } ret.flags |= flags; - janetc_nameslot(c, head, ret); + if (c->scope->flags & JANET_SCOPE_TOP) { + def_flags |= JANET_DEFFLAG_NO_UNUSED; + } + janetc_nameslot(c, head, ret, def_flags); return !isUnnamedRegister; } @@ -422,8 +481,7 @@ static int varleaf( JanetSlot refslot; JanetTable *entry = janet_table_clone(reftab); - Janet redef_kw = janet_ckeywordv("redef"); - int is_redef = janet_truthy(janet_table_get(c->env, redef_kw)); + int is_redef = c->is_redef; JanetArray *ref; JanetBinding old_binding; @@ -443,7 +501,21 @@ static int varleaf( janetc_emit_ssu(c, JOP_PUT_INDEX, refslot, s, 0, 0); return 1; } else { - return namelocal(c, sym, JANET_SLOT_MUTABLE, s); + int no_unused = reftab && reftab->count && janet_truthy(janet_table_get_keyword(reftab, "unused")); + int no_shadow = reftab && reftab->count && janet_truthy(janet_table_get_keyword(reftab, "shadow")); + uint32_t def_flags = 0; + if (no_unused) def_flags |= JANET_DEFFLAG_NO_UNUSED; + if (no_shadow) def_flags |= JANET_DEFFLAG_NO_SHADOWCHECK; + return namelocal(c, sym, JANET_SLOT_MUTABLE, s, def_flags); + } +} + +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"); + } } } @@ -453,14 +525,14 @@ static JanetSlot janetc_var(JanetFopts opts, int32_t argn, const Janet *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"); + JanetSlot ret = janetc_cslot(janet_wrap_nil()); 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; @@ -474,14 +546,15 @@ static int defleaf( const uint8_t *sym, JanetSlot s, JanetTable *tab) { + JanetTable *entry = NULL; + int is_redef = 0; if (c->scope->flags & JANET_SCOPE_TOP) { - JanetTable *entry = janet_table_clone(tab); + entry = janet_table_clone(tab); janet_table_put(entry, janet_ckeywordv("source-map"), janet_wrap_tuple(janetc_make_sourcemap(c))); - Janet redef_kw = janet_ckeywordv("redef"); - int is_redef = janet_truthy(janet_table_get(c->env, redef_kw)); - if (is_redef) janet_table_put(entry, redef_kw, janet_wrap_true()); + is_redef = c->is_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); @@ -500,11 +573,18 @@ static int defleaf( JanetSlot tabslot = janetc_cslot(janet_wrap_table(entry)); janetc_emit_sss(c, JOP_PUT, tabslot, valsym, s, 0); } - - /* Add env entry to env */ + } + int no_unused = tab && tab->count && janet_truthy(janet_table_get_keyword(tab, "unused")); + int no_shadow = is_redef || (tab && tab->count && janet_truthy(janet_table_get_keyword(tab, "shadow"))); + uint32_t def_flags = 0; + if (no_unused) def_flags |= JANET_DEFFLAG_NO_UNUSED; + if (no_shadow) def_flags |= JANET_DEFFLAG_NO_SHADOWCHECK; + int result = namelocal(c, sym, 0, s, def_flags); + if (entry) { + /* Add env entry to env AFTER namelocal to avoid the shadowcheck false positive */ janet_table_put(c->env, janet_wrap_symbol(sym), janet_wrap_table(entry)); } - return namelocal(c, sym, 0, s); + return result; } static JanetSlot janetc_def(JanetFopts opts, int32_t argn, const Janet *argv) { @@ -513,6 +593,7 @@ static JanetSlot janetc_def(JanetFopts opts, int32_t argn, const Janet *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]); @@ -520,8 +601,7 @@ static JanetSlot janetc_def(JanetFopts opts, int32_t argn, const Janet *argv) { janet_v_free(into); return janetc_cslot(janet_wrap_nil()); } - JanetSlot ret; - janet_assert(janet_v_count(into) > 0, "bad destructure"); + JanetSlot ret = janetc_cslot(janet_wrap_nil()); 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; @@ -652,8 +732,14 @@ static JanetSlot janetc_if(JanetFopts opts, int32_t argn, const Janet *argv) { /* Write jumps - only add jump lengths if jump actually emitted */ labeld = janet_v_count(c->buffer); - c->buffer[labeljr] |= (labelr - labeljr) << 16; - if (!tail) c->buffer[labeljd] |= (labeld - labeljd) << 8; + if (labeljr < labeld) { + check_16bit_jump(c, labeljr, labelr); + c->buffer[labeljr] |= (uint32_t) (labelr - labeljr) << 16; + if (!tail && labeljd < labeld) { + check_24bit_jump(c, labeljd, labeld); + c->buffer[labeljd] |= (uint32_t) (labeld - labeljd) << 8; + } + } if (tail) target.flags |= JANET_SLOT_RETURNED; return target; @@ -870,18 +956,18 @@ static JanetSlot janetc_while(JanetFopts opts, int32_t argn, const Janet *argv) } /* 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_emit(c, JOP_LOAD_SELF | ((uint32_t) tempself << 8)); + janetc_emit(c, JOP_TAILCALL | ((uint32_t) 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"); + 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_emit(c, JOP_CLOSURE | ((uint32_t) cloreg << 8) | ((uint32_t) defindex << 16)); + janetc_emit(c, JOP_CALL | ((uint32_t) cloreg << 8) | ((uint32_t) cloreg << 16)); janetc_regalloc_freetemp(&c->scope->ra, cloreg, JANETC_REGTEMP_0); c->scope->flags |= JANET_SCOPE_CLOSURE; return janetc_cslot(janet_wrap_nil()); @@ -893,13 +979,19 @@ static JanetSlot janetc_while(JanetFopts opts, int32_t argn, const Janet *argv) /* Calculate jumps */ labeld = janet_v_count(c->buffer); - if (!infinite) c->buffer[labelc] |= (uint32_t)(labeld - labelc) << 16; + if (!infinite) { + check_16bit_jump(c, labelc, labeld); + c->buffer[labelc] |= (uint32_t)(labeld - labelc) << 16; + } + + check_24bit_jump(c, labeljt, labelwt); 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); + check_24bit_jump(c, i, labeld); + c->buffer[i] = JOP_JUMP | ((uint32_t) (labeld - i) << 8); } } @@ -1032,16 +1124,24 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) { named_table = janet_table(10); named_slot = janetc_farslot(c); } else { - janetc_nameslot(c, sym, janetc_farslot(c)); + janetc_nameslot(c, sym, janetc_farslot(c), 0); } } else { - janetc_nameslot(c, sym, janetc_farslot(c)); + janetc_nameslot(c, sym, janetc_farslot(c), 0); } } 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++) { @@ -1055,14 +1155,6 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) { } janet_v_free(destructed_params); - /* 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); - } - max_arity = (vararg || allow_extra) ? INT32_MAX : arity; if (!seenopt) min_arity = arity; @@ -1084,7 +1176,9 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) { JanetSlot slot = janetc_farslot(c); slot.flags = JANET_SLOT_NAMED | JANET_FUNCTION; janetc_emit_s(c, JOP_LOAD_SELF, slot, 1); - janetc_nameslot(c, sym, slot); + /* We should figure out a better way to avoid `(def x 1) (def x :shadow (fn x [...] ...))` triggering a + * shadow lint for the last x */ + janetc_nameslot(c, sym, slot, JANET_DEFFLAG_NO_UNUSED | JANET_DEFFLAG_NO_SHADOWCHECK); } } @@ -1105,8 +1199,12 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) { 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); diff --git a/src/core/state.c b/src/core/state.c index 3d84dcd1..64dcc701 100644 --- a/src/core/state.c +++ b/src/core/state.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/core/state.h b/src/core/state.h index 86cc8a72..737b2b49 100644 --- a/src/core/state.h +++ b/src/core/state.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -182,6 +182,8 @@ struct JanetVM { JanetTable signal_handlers; #ifdef JANET_WINDOWS void **iocp; + void *connect_ex; /* MSWsock extension if available */ + int connect_ex_loaded; #elif defined(JANET_EV_EPOLL) pthread_attr_t new_thread_attr; JanetHandle selfpipe[2]; diff --git a/src/core/string.c b/src/core/string.c index 24181cbc..4e303d82 100644 --- a/src/core/string.c +++ b/src/core/string.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -476,13 +476,13 @@ JANET_CORE_FN(cfun_string_checkset, /* 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); + uint32_t mask = (uint32_t) 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); + uint32_t mask = (uint32_t) 1 << (str.bytes[i] & 0x1F); if (!(bitset[index] & mask)) { return janet_wrap_false(); } @@ -555,7 +555,9 @@ JANET_CORE_FN(cfun_string_format, "\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" + "argument to specify the maximum nesting depth to print. " + "The multiline specifiers can also take a width argument, " + "which defaults to 80 columns.\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" diff --git a/src/core/strtod.c b/src/core/strtod.c index 3873a6fd..20ae54ac 100644 --- a/src/core/strtod.c +++ b/src/core/strtod.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -49,6 +49,8 @@ #include #include +#define JANET_NUMBER_LENGTH_RIDICULOUS 0xFFFF + /* 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] = { @@ -266,7 +268,7 @@ int janet_scan_number_base( * 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; + if (len > JANET_NUMBER_LENGTH_RIDICULOUS) goto error; /* Get sign */ if (str >= end) goto error; @@ -410,10 +412,7 @@ static int scan_uint64( *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; + if (len > JANET_NUMBER_LENGTH_RIDICULOUS) return 0; /* Get sign */ if (str >= end) return 0; if (*str == '-') { diff --git a/src/core/struct.c b/src/core/struct.c index 1b1cad7b..6ca09471 100644 --- a/src/core/struct.c +++ b/src/core/struct.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/core/symcache.c b/src/core/symcache.c index 68ddf8bf..c6615be4 100644 --- a/src/core/symcache.c +++ b/src/core/symcache.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/core/symcache.h b/src/core/symcache.h index 5e3fbbe0..a3273be5 100644 --- a/src/core/symcache.h +++ b/src/core/symcache.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/core/table.c b/src/core/table.c index 910ceba2..ec418d6a 100644 --- a/src/core/table.c +++ b/src/core/table.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -155,6 +155,17 @@ Janet janet_table_get(JanetTable *t, Janet key) { 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) { diff --git a/src/core/tuple.c b/src/core/tuple.c index 7c004751..5e09e41a 100644 --- a/src/core/tuple.c +++ b/src/core/tuple.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/core/util.c b/src/core/util.c index f239d38e..90e9a601 100644 --- a/src/core/util.c +++ b/src/core/util.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -50,6 +50,7 @@ #endif #include +#include /* Base 64 lookup table for digits */ const char janet_base64[65] = @@ -268,7 +269,7 @@ int32_t janet_kv_calchash(const JanetKV *kvs, int32_t len) { return (int32_t) hash; } -/* Calculate next power of 2. May overflow. If n is 0, +/* Calculate next power of 2. May overflow. If n < 0, * will return 0. */ int32_t janet_tablen(int32_t n) { if (n < 0) return 0; @@ -277,7 +278,7 @@ int32_t janet_tablen(int32_t n) { n |= n >> 4; n |= n >> 8; n |= n >> 16; - return n + 1; + return n == INT32_MAX ? INT32_MAX : n + 1; } /* Avoid some undefined behavior that was common in the code base. */ @@ -321,6 +322,54 @@ const JanetKV *janet_dict_find(const JanetKV *buckets, int32_t cap, Janet key) { 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); @@ -525,8 +574,24 @@ static char *namebuf_name(NameBuf *namebuf, const char *suffix) { return (char *)(namebuf->buf); } +/* Add a little bit of safety when using nanboxing on arm. Instead of inserting run-time checks everywhere, we are + * only doing it during registration which has much less cost (1 shift and mask). */ +static void janet_check_pointer_align(void *p) { + (void) p; +#if defined(JANET_NANBOX_64) && JANET_NANBOX_64_POINTER_SHIFT != 0 + union { + void *p; + uintptr_t u; + } un; + un.p = p; + janet_assert(!(un.u & (uintptr_t) ((1 << JANET_NANBOX_64_POINTER_SHIFT) - 1)), + "unaligned pointer wrap - cfunction pointers and abstract types must be aligned with this nanboxing configuration."); +#endif +} + void janet_cfuns(JanetTable *env, const char *regprefix, const JanetReg *cfuns) { while (cfuns->name) { + janet_check_pointer_align(cfuns->cfun); 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); @@ -536,6 +601,7 @@ void janet_cfuns(JanetTable *env, const char *regprefix, const JanetReg *cfuns) void janet_cfuns_ext(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns) { while (cfuns->name) { + janet_check_pointer_align(cfuns->cfun); 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); @@ -547,6 +613,7 @@ void janet_cfuns_prefix(JanetTable *env, const char *regprefix, const JanetReg * NameBuf nb; if (env) namebuf_init(&nb, regprefix); while (cfuns->name) { + janet_check_pointer_align(cfuns->cfun); 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); @@ -559,6 +626,7 @@ void janet_cfuns_ext_prefix(JanetTable *env, const char *regprefix, const JanetR NameBuf nb; if (env) namebuf_init(&nb, regprefix); while (cfuns->name) { + janet_check_pointer_align(cfuns->cfun); 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); @@ -575,6 +643,7 @@ void janet_register(const char *name, JanetCFunction cfun) { /* Abstract type introspection */ void janet_register_abstract_type(const JanetAbstractType *at) { + janet_check_pointer_align((void *) 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)) { @@ -607,6 +676,7 @@ void janet_core_def_sm(JanetTable *env, const char *name, Janet x, const void *p void janet_core_cfuns_ext(JanetTable *env, const char *regprefix, const JanetRegExt *cfuns) { (void) regprefix; while (cfuns->name) { + janet_check_pointer_align(cfuns->cfun); 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); @@ -628,8 +698,11 @@ JanetBinding janet_binding_from_entry(Janet entry) { return binding; entry_table = janet_unwrap_table(entry); - /* deprecation check */ - Janet deprecate = janet_table_get(entry_table, janet_ckeywordv("deprecated")); + 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")) { @@ -643,11 +716,8 @@ JanetBinding janet_binding_from_entry(Janet entry) { binding.deprecation = JANET_BINDING_DEP_NORMAL; } - int macro = janet_truthy(janet_table_get(entry_table, janet_ckeywordv("macro"))); - Janet value = janet_table_get(entry_table, janet_ckeywordv("value")); - Janet ref = janet_table_get(entry_table, janet_ckeywordv("ref")); int ref_is_valid = janet_checktype(ref, JANET_ARRAY); - int redef = ref_is_valid && janet_truthy(janet_table_get(entry_table, janet_ckeywordv("redef"))); + int redef = ref_is_valid && janet_truthy(janet_table_get_keyword(entry_table, "redef")); if (macro) { binding.value = redef ? ref : value; @@ -843,16 +913,34 @@ int janet_checkuint16(Janet x) { return janet_checkuint16range(dval); } +int janet_checkint8(Janet x) { + if (!janet_checktype(x, JANET_NUMBER)) + return 0; + double dval = janet_unwrap_number(x); + return janet_checkint8range(dval); +} + +int janet_checkuint8(Janet x) { + if (!janet_checktype(x, JANET_NUMBER)) + return 0; + double dval = janet_unwrap_number(x); + return janet_checkuint8range(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) { diff --git a/src/core/util.h b/src/core/util.h index 4e16f5e0..d0adc0dd 100644 --- a/src/core/util.h +++ b/src/core/util.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -50,9 +50,9 @@ #ifndef JANET_EXIT #include #define JANET_EXIT(m) do { \ - fprintf(stderr, "janet internal error at line %d in file %s: %s\n",\ - __LINE__,\ + fprintf(stderr, "janet abort at %s:%d: %s\n",\ __FILE__,\ + __LINE__,\ (m));\ abort();\ } while (0) @@ -66,42 +66,72 @@ /* 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, @@ -167,7 +197,26 @@ typedef void *Clib; #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 + +#ifdef JANET_EV +#ifdef JANET_WINDOWS +#include +#include +#include +typedef struct { + union { + OVERLAPPED overlapped; + WSAOVERLAPPED wsaoverlapped; + } as; + uint32_t bytes_transfered; +} JanetOverlapped; +#endif +#endif /* Initialize builtin libraries */ void janet_lib_io(JanetTable *env); diff --git a/src/core/value.c b/src/core/value.c index b278a1bc..bd673362 100644 --- a/src/core/value.c +++ b/src/core/value.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -322,7 +322,8 @@ int32_t janet_hash(Janet x) { break; case JANET_TUPLE: hash = janet_tuple_hash(janet_unwrap_tuple(x)); - hash += (janet_tuple_flag(janet_unwrap_tuple(x)) & JANET_TUPLE_FLAG_BRACKETCTOR) ? 1 : 0; + 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)); @@ -334,10 +335,9 @@ int32_t janet_hash(Janet x) { } as; as.d = janet_unwrap_number(x); as.d += 0.0; /* normalize negative 0 */ - uint32_t lo = (uint32_t)(as.u & 0xFFFFFFFF); + as.u = murmur64(as.u); uint32_t hi = (uint32_t)(as.u >> 32); - uint32_t hilo = (hi ^ lo) * 2654435769u; - hash = (int32_t)((hilo << 16) | (hilo >> 16)); + hash = (int32_t)hi; break; } case JANET_ABSTRACT: { @@ -495,7 +495,7 @@ Janet janet_in(Janet ds, Janet key) { 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); + janet_panicf("no getter for %v", ds); } break; } @@ -622,7 +622,7 @@ Janet janet_getindex(Janet ds, int32_t index) { if (!(type->get)(janet_unwrap_abstract(ds), janet_wrap_integer(index), &value)) value = janet_wrap_nil(); } else { - janet_panicf("no getter for %v ", ds); + janet_panicf("no getter for %v", ds); } break; } @@ -724,6 +724,9 @@ void janet_putindex(Janet ds, int32_t index, Janet value) { 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; @@ -735,6 +738,7 @@ void janet_putindex(Janet ds, int32_t index, Janet 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); @@ -767,7 +771,11 @@ void janet_put(Janet ds, Janet key, Janet value) { JanetArray *array = janet_unwrap_array(ds); int32_t index = getter_checkint(type, key, INT32_MAX - 1); if (index >= array->count) { - janet_array_setcount(array, index + 1); + 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; @@ -778,7 +786,9 @@ void janet_put(Janet ds, Janet key, Janet value) { if (!janet_checkint(value)) janet_panicf("can only put integers in buffers, got %v", value); if (index >= buffer->count) { - janet_buffer_setcount(buffer, index + 1); + 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; diff --git a/src/core/vector.c b/src/core/vector.c index 64f1e780..47182355 100644 --- a/src/core/vector.c +++ b/src/core/vector.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/core/vector.h b/src/core/vector.h index 5aa24c13..4341ee63 100644 --- a/src/core/vector.h +++ b/src/core/vector.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/src/core/vm.c b/src/core/vm.c index a0dae1c8..0cfa7ee9 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -129,7 +129,9 @@ if (!janet_checktype(op1, JANET_NUMBER)) {\ vm_commit();\ Janet _argv[2] = { op1, janet_wrap_number(CS) };\ - stack[A] = janet_mcall(#op, 2, _argv);\ + 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);\ @@ -143,7 +145,9 @@ if (!janet_checktype(op1, JANET_NUMBER)) {\ vm_commit();\ Janet _argv[2] = { op1, janet_wrap_number(CS) };\ - stack[A] = janet_mcall(#op, 2, _argv);\ + 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);\ @@ -166,7 +170,9 @@ vm_pcnext();\ } else {\ vm_commit();\ - stack[A] = janet_binop_call(#op, "r" #op, op1, op2);\ + Janet a = janet_binop_call(#op, "r" #op, op1, op2);\ + stack = fiber->data + fiber->frame;\ + stack[A] = a;\ vm_checkgc_pcnext();\ }\ } @@ -186,7 +192,9 @@ vm_pcnext();\ } else {\ vm_commit();\ - stack[A] = janet_binop_call(#op, "r" #op, op1, op2);\ + Janet a = janet_binop_call(#op, "r" #op, op1, op2);\ + stack = fiber->data + fiber->frame;\ + stack[A] = a;\ vm_checkgc_pcnext();\ }\ } @@ -203,7 +211,9 @@ vm_pcnext();\ } else {\ vm_commit();\ - stack[A] = janet_wrap_boolean(janet_compare(op1, op2) op 0);\ + Janet a = janet_wrap_boolean(janet_compare(op1, op2) op 0);\ + stack = fiber->data + fiber->frame;\ + stack[A] = a;\ vm_checkgc_pcnext();\ }\ } @@ -217,23 +227,29 @@ vm_pcnext();\ } else {\ vm_commit();\ - stack[A] = janet_wrap_boolean(janet_compare(op1, janet_wrap_integer(CS)) op 0);\ + 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"); -} +/* Trace a function call. + * This is a macro to avoid stale argv if janet_eprintf resizes the stack + */ +#define vm_do_trace(func, argc, argv) do { \ + JanetFunction* _func = (func);\ + if (_func->def->name) {\ + janet_eprintf("trace (%S", _func->def->name);\ + } else {\ + janet_eprintf("trace (%p", janet_wrap_function(_func));\ + }\ + int32_t _argc = (argc);\ + for (int32_t i = 0; i < _argc; i++) {\ + janet_eprintf(" %p", (argv)[i]);\ + }\ + janet_eprintf(")\n");\ +} while (0) /* Invoke a method once we have looked it up */ static Janet janet_method_invoke(Janet method, int32_t argc, Janet *argv) { @@ -602,10 +618,13 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { register uint32_t *pc; register JanetFunction *func; + /* NOTE: Flag smuggling! We "smuggle" the fiber sigal in the gc.flags field instead of the usual flags field */ if (fiber->flags & JANET_FIBER_RESUME_SIGNAL) { + /* Get the signal */ JanetSignal sig = (fiber->gc.flags & JANET_FIBER_STATUS_MASK) >> JANET_FIBER_STATUS_OFFSET; + /* Clear the signal */ fiber->gc.flags &= ~JANET_FIBER_STATUS_MASK; - fiber->flags &= ~(JANET_FIBER_RESUME_SIGNAL | JANET_FIBER_FLAG_MASK); + fiber->flags &= ~JANET_FIBER_RESUME_SIGNAL; janet_vm.return_reg[0] = in; return sig; } @@ -710,7 +729,9 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { vm_pcnext(); } else { vm_commit(); - stack[A] = janet_binop_call("div", "rdiv", op1, op2); + Janet a = janet_binop_call("div", "rdiv", op1, op2); + stack = fiber->data + fiber->frame; + stack[A] = a; vm_checkgc_pcnext(); } } @@ -730,7 +751,9 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { vm_pcnext(); } else { vm_commit(); - stack[A] = janet_binop_call("mod", "rmod", op1, op2); + Janet a = janet_binop_call("mod", "rmod", op1, op2); + stack = fiber->data + fiber->frame; + stack[A] = a; vm_checkgc_pcnext(); } } @@ -745,7 +768,9 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { vm_pcnext(); } else { vm_commit(); - stack[A] = janet_binop_call("%", "r%", op1, op2); + Janet a = janet_binop_call("%", "r%", op1, op2); + stack = fiber->data + fiber->frame; + stack[A] = a; vm_checkgc_pcnext(); } } @@ -766,7 +791,9 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { vm_pcnext(); } else { vm_commit(); - stack[A] = janet_unary_call("~", op); + Janet a = janet_unary_call("~", op); + stack = fiber->data + fiber->frame; + stack[A] = a; vm_checkgc_pcnext(); } } @@ -872,8 +899,11 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { stack[A] = janet_wrap_boolean(!janet_checktype(stack[B], JANET_NUMBER) || (janet_unwrap_number(stack[B]) != (double) CS)); vm_pcnext(); - VM_OP(JOP_COMPARE) - stack[A] = janet_wrap_integer(janet_compare(stack[B], stack[C])); + 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) @@ -1104,11 +1134,11 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { } fiber->child = child; JanetSignal sig = janet_continue_no_check(child, stack[C], &retreg); + stack = fiber->data + fiber->frame; 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(); } @@ -1157,6 +1187,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { 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(); @@ -1164,27 +1195,44 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) { 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(); - stack[A] = janet_in(stack[B], stack[C]); + { + Janet a = janet_in(stack[B], stack[C]); + stack = fiber->data + fiber->frame; + stack[A] = a; + } vm_pcnext(); VM_OP(JOP_GET) vm_commit(); - stack[A] = janet_get(stack[B], stack[C]); + { + 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(); - stack[A] = janet_getindex(stack[B], C); + { + Janet a = janet_getindex(stack[B], C); + stack = fiber->data + fiber->frame; + stack[A] = a; + } vm_pcnext(); VM_OP(JOP_LENGTH) vm_commit(); - stack[A] = janet_lengthv(stack[E]); + { + Janet a = janet_lengthv(stack[E]); + stack = fiber->data + fiber->frame; + stack[A] = a; + } vm_pcnext(); VM_OP(JOP_MAKE_ARRAY) { @@ -1412,7 +1460,7 @@ static JanetSignal janet_check_can_resume(JanetFiber *fiber, Janet *out, int is_ } /* 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)) { + if (janet_vm.fiber != NULL && (fiber->gc.flags & JANET_FIBER_EV_GCFLAG_ROOT)) { #ifdef JANET_EV *out = janet_cstringv(is_cancel ? "cannot cancel root fiber, use ev/cancel" @@ -1518,6 +1566,15 @@ static JanetSignal janet_continue_no_check(JanetFiber *fiber, Janet in, Janet *o } } + /* If this is a nested continue (root_fiber already set), root the fiber + * so it survives GC. janet_collect only marks root_fiber, so without + * this a nested fiber (e.g., from janet_pcall in a C function) would be + * invisible to GC and could be collected while actively running. */ + int fiber_rooted = (janet_vm.root_fiber != NULL); + if (fiber_rooted) { + janet_gcroot(janet_wrap_fiber(fiber)); + } + /* Save global state */ JanetTryState tstate; JanetSignal sig = janet_try(&tstate); @@ -1533,6 +1590,9 @@ static JanetSignal janet_continue_no_check(JanetFiber *fiber, Janet in, Janet *o if (janet_vm.root_fiber == fiber) janet_vm.root_fiber = NULL; janet_fiber_set_status(fiber, sig); janet_restore(&tstate); + if (fiber_rooted) { + janet_gcunroot(janet_wrap_fiber(fiber)); + } fiber->last_value = tstate.payload; *out = tstate.payload; @@ -1554,6 +1614,8 @@ JanetSignal janet_continue_signal(JanetFiber *fiber, Janet in, Janet *out, Janet if (sig != JANET_SIGNAL_OK) { JanetFiber *child = fiber; while (child->child) child = child->child; + /* NOTE: We are "smuggling" flags in for later use in an unusal place. This is odd but intentional and + * saves a bit of memory per fiber rather than creating a new field. There is likely a better way to do this. */ child->gc.flags &= ~JANET_FIBER_STATUS_MASK; child->gc.flags |= sig << JANET_FIBER_STATUS_OFFSET; child->flags |= JANET_FIBER_RESUME_SIGNAL; diff --git a/src/core/wrap.c b/src/core/wrap.c index c4fc1d16..d44620e9 100644 --- a/src/core/wrap.c +++ b/src/core/wrap.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -194,12 +194,18 @@ Janet janet_wrap_number_safe(double d) { void *janet_nanbox_to_pointer(Janet x) { x.i64 &= JANET_NANBOX_PAYLOADBITS; + x.u64 <<= JANET_NANBOX_64_POINTER_SHIFT; /* Alignment, usually 0 */ return x.pointer; } Janet janet_nanbox_from_pointer(void *p, uint64_t tagmask) { Janet ret; ret.pointer = p; + /* Should be noop when pointer shift is 0 */ + /* + janet_assert(!(ret.u64 & (uint64_t) ((1 << JANET_NANBOX_64_POINTER_SHIFT) - 1)), "unaligned pointer wrap"); + */ + ret.u64 >>= JANET_NANBOX_64_POINTER_SHIFT; /* Alignment, usually 0 */ ret.u64 |= tagmask; return ret; } @@ -207,6 +213,11 @@ Janet janet_nanbox_from_pointer(void *p, uint64_t tagmask) { Janet janet_nanbox_from_cpointer(const void *p, uint64_t tagmask) { Janet ret; ret.pointer = (void *)p; + /* Should be noop when pointer shift is 0 */ + /* + janet_assert(!(ret.u64 & (uint64_t) ((1 << JANET_NANBOX_64_POINTER_SHIFT) - 1)), "unaligned pointer wrap"); + */ + ret.u64 >>= JANET_NANBOX_64_POINTER_SHIFT; /* Alignment, usually 0 */ ret.u64 |= tagmask; return ret; } diff --git a/src/include/janet.h b/src/include/janet.h index 2084418a..c243e68a 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -67,6 +67,11 @@ extern "C" { #define JANET_LINUX 1 #endif +/* Check for GNU Hurd */ +#ifdef __gnu_hurd__ +#define JANET_GNU_HURD 1 +#endif + /* Check for Android */ #ifdef __ANDROID__ #define JANET_ANDROID 1 @@ -121,6 +126,7 @@ extern "C" { || (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 */ @@ -147,6 +153,7 @@ extern "C" { || 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 @@ -305,25 +312,38 @@ extern "C" { * 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) +#elif defined(__x86_64__) || defined(_WIN64) || defined(__riscv) || defined(__aarch64__) || defined(_M_ARM64) /* 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 + * for x64, risc-v, and arm64. 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. */ + * and it requires cooperation from the OS. ARM should also work in many configurations by taking advantage + * of pointer alignment to allow for 48 or 49 bits of address space. */ #define JANET_NANBOX_64 + +/* Allow 64-bit nanboxing to assume aligned pointers to get back some extra bits for representation. + * This is needed to use nanboxing on systems with larger than 47-bit address spaces, such as many + * aarch64 systems. */ +#ifndef JANET_NANBOX_64_POINTER_SHIFT +#if (defined(_M_ARM64) || defined(__aarch64__)) && !defined(JANET_APPLE) +/* All pointers, including function pointers, should be 4-byte aligned on aarch64 by default. + * The exception is aarch64 macos, as it uses the same 47-bit userland address-space as on amd64. */ +#define JANET_NANBOX_64_POINTER_SHIFT 2 #endif #endif +#endif +#endif + +/* Allow for custom pointer alignment as well */ +#if defined(JANET_NANBOX_64) && !defined(JANET_NANBOX_64_POINTER_SHIFT) +#define JANET_NANBOX_64_POINTER_SHIFT 0 +#endif /* Runtime config constants */ #ifdef JANET_NO_NANBOX -#define JANET_NANBOX_BIT 0 +#define JANET_NANBOX_BIT 0x0 #else #define JANET_NANBOX_BIT 0x1 #endif @@ -334,9 +354,16 @@ extern "C" { #define JANET_SINGLE_THREADED_BIT 0 #endif +#ifdef JANET_NANBOX_64_POINTER_SHIFT +#define JANET_NANBOX_POINTER_SHIFT_BITS (JANET_NANBOX_64_POINTER_SHIFT ? (0x4 << JANET_NANBOX_64_POINTER_SHIFT) : 0) +#else +#define JANET_NANBOX_POINTER_SHIFT_BITS 0 +#endif + #define JANET_CURRENT_CONFIG_BITS \ (JANET_SINGLE_THREADED_BIT | \ - JANET_NANBOX_BIT) + JANET_NANBOX_BIT | \ + JANET_NANBOX_POINTER_SHIFT_BITS) /* Represents the settings used to compile Janet, as well as the version */ typedef struct { @@ -601,6 +628,7 @@ typedef void *JanetAbstract; #define JANET_STREAM_UDPSERVER 0x1000 #define JANET_STREAM_NOT_CLOSEABLE 0x2000 #define JANET_STREAM_TOCLOSE 0x10000 +#define JANET_STREAM_NODUPS 0x20000 typedef enum { JANET_ASYNC_EVENT_INIT = 0, @@ -666,6 +694,8 @@ JANET_API void janet_stream_level_triggered(JanetStream *stream); * signals. Define them here */ #ifdef JANET_WINDOWS typedef long JanetAtomicInt; +#elif defined(JANET_PLAN9) +typedef long JanetAtomicInt; #else typedef int32_t JanetAtomicInt; #endif @@ -915,6 +945,8 @@ JANET_API Janet janet_nanbox32_from_tagp(uint32_t tag, void *pointer); /* End of tagged union implementation */ #endif +JANET_API int janet_checkint8(Janet x); +JANET_API int janet_checkuint8(Janet x); JANET_API int janet_checkint16(Janet x); JANET_API int janet_checkuint16(Janet x); JANET_API int janet_checkint(Janet x); @@ -923,6 +955,8 @@ 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_checkint8range(x) ((x) >= INT8_MIN && (x) <= INT8_MAX && (x) == (int8_t)(x)) +#define janet_checkuint8range(x) ((x) >= 0 && (x) <= UINT8_MAX && (x) == (uint8_t)(x)) #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)) @@ -1070,6 +1104,7 @@ struct JanetAbstractHead { #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 */ @@ -1111,6 +1146,7 @@ struct JanetFuncDef { int32_t environments_length; int32_t defs_length; int32_t symbolmap_length; + int32_t named_args_count; }; /* A function environment */ @@ -1134,9 +1170,21 @@ struct JanetFunction { 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, @@ -1164,15 +1212,19 @@ struct JanetParser { }; /* A context for marshaling and unmarshaling abstract types */ -typedef struct { +struct JanetMarshalContext { void *m_state; void *u_state; int flags; const uint8_t *data; const JanetAbstractType *at; -} JanetMarshalContext; +}; +typedef struct JanetMarshalContext JanetMarshalContext; -/* Defines an abstract type */ +/* 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); @@ -1260,6 +1312,7 @@ typedef struct JanetFile JanetFile; struct JanetFile { FILE *file; int32_t flags; + size_t vbufsize; }; /* For janet_try and janet_restore */ @@ -1393,7 +1446,7 @@ enum JanetOpCode { }; /* Info about all instructions */ -extern enum JanetInstructionType janet_instructions[JOP_INSTRUCTION_COUNT]; +extern const enum JanetInstructionType janet_instructions[JOP_INSTRUCTION_COUNT]; /***** END SECTION OPCODES *****/ @@ -1424,6 +1477,7 @@ JANET_API void janet_loop(void); * } else { * janet_schedule(interrupted_fiber, janet_wrap_nil()); * } + * janet_interpreter_interrupt_handled(NULL); * } * } * @@ -1463,9 +1517,18 @@ JANET_API void janet_ev_dec_refcount(void); 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); @@ -1474,7 +1537,7 @@ JANET_API JanetChannel *janet_optchannel(const Janet *argv, int32_t argc, int32_ 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 */ +/* 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); @@ -1542,7 +1605,8 @@ JANET_API void janet_ev_post_event(JanetVM *vm, JanetCallback cb, JanetEVGeneric /* Callback used by janet_ev_threaded_await */ JANET_API void janet_ev_default_threaded_callback(JanetEVGenericMessage return_value); -/* Read async from a stream */ +/* 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 @@ -1551,7 +1615,8 @@ JANET_NO_RETURN JANET_API void janet_ev_recvchunk(JanetStream *stream, JanetBuff JANET_NO_RETURN JANET_API void janet_ev_recvfrom(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int flags); #endif -/* Write async to a stream */ +/* 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 @@ -1563,17 +1628,63 @@ JANET_NO_RETURN JANET_API void janet_ev_sendto_string(JanetStream *stream, Janet #endif -/* Parsing */ +/* 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 */ @@ -1617,7 +1728,10 @@ JANET_API JanetCompileResult janet_compile_lint( JANET_API JanetTable *janet_core_env(JanetTable *replacements); JANET_API JanetTable *janet_core_lookup_table(JanetTable *replacements); -/* Execute strings */ +/* 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 @@ -1811,21 +1925,41 @@ 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 */ -JANET_API void janet_mark(Janet x); -JANET_API void janet_sweep(void); + +/* The main interface to garbage collection. Call this to do a full mark and sweep cleanup. */ JANET_API void janet_collect(void); -JANET_API void janet_clear_memory(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); -JANET_API int janet_gcunrootall(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 */ @@ -1874,7 +2008,7 @@ 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); +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); @@ -1903,6 +2037,11 @@ JANET_API void janet_stacktrace_ext(JanetFiber *fiber, Janet err, const char *pr #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_EXIT 524288 #define JANET_SANDBOX_ALL (UINT32_MAX) JANET_API void janet_sandbox(uint32_t flags); JANET_API void janet_sandbox_assert(uint32_t forbidden_flags); @@ -1947,10 +2086,23 @@ 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 */ +/* 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. + * + * */ + +#if defined(JANET_NANBOX_64) && (JANET_NANBOX_64_POINTER_SHIFT != 0) && !defined(JANET_MSVC) +#define JANET_CFUNCTION_ALIGN __attribute__((aligned(1 << JANET_NANBOX_64_POINTER_SHIFT))) +#else +#define JANET_CFUNCTION_ALIGN +#endif /* Shorthand for janet C function declarations */ -#define JANET_CFUN(name) Janet name (int32_t argc, Janet *argv) +#define JANET_CFUN(name) JANET_CFUNCTION_ALIGN 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} @@ -1966,7 +2118,7 @@ JANET_API Janet janet_resolve_core(const char *name); #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) + Janet JANET_CFUNCTION_ALIGN CNAME (int32_t argc, Janet *argv) #define JANET_DEF_S(ENV, JNAME, VAL, DOC) \ janet_def_sm(ENV, JNAME, VAL, NULL, __FILE__, __LINE__) @@ -1974,7 +2126,7 @@ JANET_API Janet janet_resolve_core(const char *name); #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) + Janet JANET_CFUNCTION_ALIGN CNAME (int32_t argc, Janet *argv) #define JANET_DEF_D(ENV, JNAME, VAL, DOC) \ janet_def(ENV, JNAME, VAL, DOC) @@ -1983,7 +2135,7 @@ JANET_API Janet janet_resolve_core(const char *name); #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) + Janet JANET_CFUNCTION_ALIGN CNAME (int32_t argc, Janet *argv) #define JANET_DEF_SD(ENV, JNAME, VAL, DOC) \ janet_def_sm(ENV, JNAME, VAL, DOC, __FILE__, __LINE__) @@ -2066,9 +2218,12 @@ 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 float janet_getfloat(const Janet *argv, int32_t n); +JANET_API int8_t janet_getinteger8(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 uint8_t janet_getuinteger8(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); @@ -2102,6 +2257,8 @@ JANET_API int32_t janet_optinteger(const Janet *argv, int32_t argc, int32_t n, i 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); @@ -2143,6 +2300,7 @@ 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 int janet_marshal_flags(JanetMarshalContext *ctx); JANET_API void janet_unmarshal_ensure(JanetMarshalContext *ctx, size_t size); JANET_API size_t janet_unmarshal_size(JanetMarshalContext *ctx); @@ -2155,6 +2313,7 @@ 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 int janet_unmarshal_flags(JanetMarshalContext *ctx); JANET_API void janet_register_abstract_type(const JanetAbstractType *at); JANET_API const JanetAbstractType *janet_get_abstract_type(Janet key); @@ -2202,7 +2361,9 @@ typedef enum { RULE_SPLIT, /* [rule, rule] */ RULE_NTH, /* [nth, rule, tag] */ RULE_ONLY_TAGS, /* [rule] */ -} JanetPegOpcod; + RULE_MATCHSPLICE, /* [rule, constant, tag] */ + RULE_DEBUG, /* [] */ +} JanetPegOpcode; typedef struct { uint32_t *bytecode; diff --git a/src/mainclient/shell.c b/src/mainclient/shell.c index 3d95ee2d..cd918a7e 100644 --- a/src/mainclient/shell.c +++ b/src/mainclient/shell.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 @@ -26,6 +26,7 @@ #include #include +#include #ifdef _WIN32 #include @@ -79,9 +80,11 @@ static void simpleline(JanetBuffer *buffer) { int c; for (;;) { c = fgetc(in); +#ifndef JANET_PLAN9 if (c < 0 && !feof(in) && errno == EINTR) { continue; } +#endif if (feof(in) || c < 0) { break; } @@ -110,6 +113,8 @@ 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 */ @@ -307,7 +312,9 @@ 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; @@ -356,33 +363,52 @@ static void clear(void) { } } +static int getplen(void) { + int _plen = gbl_plen; + /* Ensure at least 16 characters of data entry; */ + while (_plen && (_plen + 16 > gbl_cols)) { + _plen--; + } + return _plen; +} + static void refresh(void) { char seq[64]; JanetBuffer b; + /* If prompt is too long, truncate */ + int _plen = getplen(); + /* Keep cursor position on screen */ char *_buf = gbl_buf; int _len = gbl_len; int _pos = gbl_pos; - while ((gbl_plen + _pos) >= gbl_cols) { + + while ((_plen + _pos) >= gbl_cols) { _buf++; _len--; _pos--; } - while ((gbl_plen + _len) > gbl_cols) { + + while ((_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); + janet_buffer_push_bytes(&b, (const uint8_t *) gbl_prompt, _plen); + if (_len > 0) { + janet_buffer_push_bytes(&b, (uint8_t *) _buf, _len); + } /* Erase to right */ - janet_buffer_push_cstring(&b, "\x1b[0K"); + janet_buffer_push_cstring(&b, "\x1b[0K\r"); /* Move cursor to original position. */ - snprintf(seq, 64, "\r\x1b[%dC", (int)(_pos + gbl_plen)); - janet_buffer_push_cstring(&b, seq); + if (_pos + _plen) { + snprintf(seq, 64, "\x1b[%dC", (int)(_pos + _plen)); + janet_buffer_push_cstring(&b, seq); + } if (write_console((char *) b.data, b.count) == -1) { exit(1); } @@ -406,7 +432,8 @@ static int insert(char c, int draw) { gbl_buf[gbl_pos++] = c; gbl_buf[++gbl_len] = '\0'; if (draw) { - if (gbl_plen + gbl_len < gbl_cols) { + int _plen = getplen(); + if (_plen + gbl_len < gbl_cols) { /* Avoid a full update of the line in the * trivial case. */ if (write_console(&c, 1) == -1) return -1; @@ -424,6 +451,63 @@ static int insert(char c, int draw) { 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]); @@ -435,8 +519,13 @@ static void historymove(int delta) { } else if (gbl_historyi >= gbl_history_count) { gbl_historyi = gbl_history_count - 1; } + gbl_len = (int) strlen(gbl_history[gbl_historyi]); + /* If history element is longer the JANET_LINE_MAX - 1, truncate */ + if (gbl_len > JANET_LINE_MAX - 1) { + gbl_len = JANET_LINE_MAX - 1; + } + gbl_pos = gbl_len; 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(); @@ -860,11 +949,12 @@ static int line() { gbl_len = 0; gbl_pos = 0; while (gbl_prompt[gbl_plen]) gbl_plen++; + int _plen = getplen(); gbl_buf[0] = '\0'; addhistory(); - if (write_console((char *) gbl_prompt, gbl_plen) == -1) return -1; + if (write_console((char *) gbl_prompt, _plen) == -1) return -1; for (;;) { char c; char seq[5]; @@ -890,6 +980,7 @@ static int line() { case 3: /* ctrl-c */ clearlines(); norawmode(); + savehistory(); #ifdef _WIN32 ExitProcess(1); #else @@ -1083,17 +1174,21 @@ void janet_line_init() { } void janet_line_deinit() { - int i; norawmode(); - for (i = 0; i < gbl_history_count; i++) + 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()) { @@ -1129,6 +1224,10 @@ int main(int argc, char **argv) { JanetArray *args; JanetTable *env; +#ifdef JANET_PLAN9 + setfcr(0); +#endif + #ifdef _WIN32 setup_console_output(); #endif @@ -1138,7 +1237,7 @@ int main(int argc, char **argv) { #endif #if defined(JANET_PRF) - uint8_t hash_key[JANET_HASH_KEY_SIZE + 1]; + uint8_t hash_key[JANET_HASH_KEY_SIZE + 1] = {0}; #ifdef JANET_REDUCED_OS char *envvar = NULL; #else @@ -1146,6 +1245,7 @@ int main(int argc, char **argv) { #endif if (NULL != envvar) { strncpy((char *) hash_key, envvar, sizeof(hash_key) - 1); + hash_key[JANET_HASH_KEY_SIZE] = '\0'; /* in case copy didn't get null byte */ } else if (janet_cryptorand(hash_key, JANET_HASH_KEY_SIZE) != 0) { fputs("unable to initialize janet PRF hash function.\n", stderr); return 1; @@ -1184,6 +1284,10 @@ int main(int argc, char **argv) { status = janet_loop_fiber(fiber); /* Deinitialize vm */ + +#if !defined(JANET_SIMPLE_GETLINE) + savehistory(); +#endif janet_deinit(); janet_line_deinit(); diff --git a/test/amalg/main.c b/test/amalg/main.c index 3bcc688b..9b5a503e 100644 --- a/test/amalg/main.c +++ b/test/amalg/main.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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 diff --git a/test/c/test-gc-pcall.c b/test/c/test-gc-pcall.c new file mode 100644 index 00000000..fc37b8ba --- /dev/null +++ b/test/c/test-gc-pcall.c @@ -0,0 +1,143 @@ +/* + * Test that GC does not collect fibers during janet_pcall. + * + * Bug: janet_collect() marks janet_vm.root_fiber but not janet_vm.fiber. + * When janet_pcall is called from a C function, the inner fiber becomes + * janet_vm.fiber while root_fiber still points to the outer fiber. If GC + * triggers inside the inner fiber's execution, the inner fiber is not in + * any GC root set and can be collected — including its stack memory — + * while it is actively running. + * + * Two tests: + * 1. Single nesting: F1 -> C func -> janet_pcall -> F2 + * F2 is not marked (it's janet_vm.fiber but not root_fiber) + * 2. Deep nesting: F1 -> C func -> janet_pcall -> F2 -> C func -> janet_pcall -> F3 + * F2 is not marked (saved only in a C stack local tstate.vm_fiber) + * + * Build (after building janet): + * cc -o build/test-gc-pcall test/test-gc-pcall.c \ + * -Isrc/include -Isrc/conf build/libjanet.a -lm -lpthread -ldl + * + * Run: + * ./build/test-gc-pcall + */ + +#include "janet.h" +#include + +/* C function that calls a Janet callback via janet_pcall. */ +static Janet cfun_call_via_pcall(int32_t argc, Janet *argv) { + janet_fixarity(argc, 1); + JanetFunction *fn = janet_getfunction(argv, 0); + + Janet result; + JanetFiber *fiber = NULL; + JanetSignal sig = janet_pcall(fn, 0, NULL, &result, &fiber); + + if (sig != JANET_SIGNAL_OK) { + janet_panicv(result); + } + + return result; +} + +static int run_test(JanetTable *env, const char *name, const char *source) { + printf(" %s... ", name); + fflush(stdout); + Janet result; + int status = janet_dostring(env, source, name, &result); + if (status != 0) { + printf("FAIL (crashed or errored)\n"); + return 1; + } + printf("PASS\n"); + return 0; +} + +/* Test 1: Single nesting. + * F1 -> cfun_call_via_pcall -> janet_pcall -> F2 + * F2 is janet_vm.fiber but not root_fiber, so GC can collect it. + * + * All allocations are done in Janet code so GC checks trigger in the + * VM loop (janet_gcalloc does NOT call janet_collect — only the VM's + * vm_checkgc_next does). */ +static const char test_single[] = + "(gcsetinterval 1024)\n" + "(def cb\n" + " (do\n" + " (def captured @{:key \"value\" :nested @[1 2 3 4 5]})\n" + " (fn []\n" + " (var result nil)\n" + " (for i 0 500\n" + " (def t @{:i i :s (string \"iter-\" i) :arr @[i (+ i 1) (+ i 2)]})\n" + " (set result (get captured :key)))\n" + " result)))\n" + "(for round 0 200\n" + " (def result (call-via-pcall cb))\n" + " (assert (= result \"value\")\n" + " (string \"round \" round \": expected 'value', got \" (describe result))))\n"; + +/* Test 2: Deep nesting. + * F1 -> cfun_call_via_pcall -> janet_pcall -> F2 -> cfun_call_via_pcall -> janet_pcall -> F3 + * F2 is saved only in C stack local tstate.vm_fiber, invisible to GC. + * F2's stack data can be freed if F2 is collected during F3's execution. + * + * The inner callback allocates in Janet code (not C) to ensure the + * VM loop triggers GC checks during F3's execution. */ +static const char test_deep[] = + "(gcsetinterval 1024)\n" + "(def inner-cb\n" + " (do\n" + " (def captured @{:key \"deep\" :nested @[10 20 30]})\n" + " (fn []\n" + " (var result nil)\n" + " (for i 0 500\n" + " (def t @{:i i :s (string \"iter-\" i) :arr @[i (+ i 1) (+ i 2)]})\n" + " (set result (get captured :key)))\n" + " result)))\n" + "\n" + "(def outer-cb\n" + " (do\n" + " (def state @{:count 0 :data @[\"a\" \"b\" \"c\" \"d\" \"e\"]})\n" + " (fn []\n" + " # This runs on F2. Calling call-via-pcall here creates F3.\n" + " # F2 becomes unreachable: it's not root_fiber (that's F1)\n" + " # and it's no longer janet_vm.fiber (that's now F3).\n" + " (def inner-result (call-via-pcall inner-cb))\n" + " # If F2 was collected during F3's execution, accessing\n" + " # state here reads freed memory.\n" + " (put state :count (+ (state :count) 1))\n" + " (string inner-result \"-\" (state :count)))))\n" + "\n" + "(for round 0 200\n" + " (def result (call-via-pcall outer-cb))\n" + " (def expected (string \"deep-\" (+ round 1)))\n" + " (assert (= result expected)\n" + " (string \"round \" round \": expected '\" expected \"', got '\" (describe result) \"'\")))\n"; + +int main(int argc, char **argv) { + (void)argc; + (void)argv; + int failures = 0; + + janet_init(); + + JanetTable *env = janet_core_env(NULL); + + janet_def(env, "call-via-pcall", + janet_wrap_cfunction(cfun_call_via_pcall), + "Call a function via janet_pcall from C."); + + printf("Testing janet_pcall GC safety:\n"); + failures += run_test(env, "single-nesting", test_single); + failures += run_test(env, "deep-nesting", test_deep); + + janet_deinit(); + + if (failures > 0) { + printf("\n%d test(s) FAILED\n", failures); + return 1; + } + printf("\nAll tests passed.\n"); + return 0; +} diff --git a/test/fuzzers/fuzz_compile.c b/test/fuzzers/fuzz_compile.c new file mode 100644 index 00000000..953bb090 --- /dev/null +++ b/test/fuzzers/fuzz_compile.c @@ -0,0 +1,41 @@ +#include +#include + +/* Disable leak sanitizer */ +int __lsan_is_turned_off(void) { + return 1; +} + +int LLVMFuzzerTestOneInput(const uint8_t *data, size_t size) { + + /* init Janet */ + janet_init(); + + /* fuzz the compiler in src/core/compile.c: parse the untrusted source and + compile each produced form to bytecode */ + JanetTable *env = janet_core_env(NULL); + JanetParser parser; + janet_parser_init(&parser); + + JanetTryState tstate; + if (janet_try(&tstate) == JANET_SIGNAL_OK) { + for (size_t i = 0; i < size; i++) { + if (janet_parser_status(&parser) == JANET_PARSE_ERROR) + break; + janet_parser_consume(&parser, data[i]); + while (janet_parser_has_more(&parser)) { + Janet form = janet_parser_produce(&parser); + JanetCompileResult res = janet_compile(form, env, janet_cstring("fuzz")); + (void) res; + } + } + } + janet_restore(&tstate); + + janet_parser_deinit(&parser); + + /* cleanup Janet */ + janet_deinit(); + + return 0; +} diff --git a/test/fuzzers/fuzz_dobytes.c b/test/fuzzers/fuzz_dobytes.c new file mode 100644 index 00000000..4f0fb01d --- /dev/null +++ b/test/fuzzers/fuzz_dobytes.c @@ -0,0 +1,27 @@ +#include +#include + +/* Disable leak sanitizer */ +int __lsan_is_turned_off(void) { + return 1; +} + +int LLVMFuzzerTestOneInput(const uint8_t *data, size_t size) { + + /* init Janet */ + janet_init(); + + /* fuzz the compile + bytecode VM path (parse, compile, run) in src/core/compile.c and src/core/vm.c */ + JanetTable *env = janet_core_env(NULL); + JanetTryState tstate; + if (janet_try(&tstate) == JANET_SIGNAL_OK) { + Janet out; + janet_dobytes(env, data, (int32_t) size, "", &out); + } + janet_restore(&tstate); + + /* cleanup Janet */ + janet_deinit(); + + return 0; +} diff --git a/test/fuzzers/fuzz_unmarshal.c b/test/fuzzers/fuzz_unmarshal.c new file mode 100644 index 00000000..2434c2dd --- /dev/null +++ b/test/fuzzers/fuzz_unmarshal.c @@ -0,0 +1,27 @@ +#include +#include + +/* Disable leak sanitizer */ +int __lsan_is_turned_off(void) { + return 1; +} + +int LLVMFuzzerTestOneInput(const uint8_t *data, size_t size) { + + /* init Janet */ + janet_init(); + + /* fuzz the binary unmarshal (deserialization) path in src/core/marsh.c */ + JanetTable *reg = janet_env_lookup(janet_core_env(NULL)); + JanetTryState tstate; + if (janet_try(&tstate) == JANET_SIGNAL_OK) { + const uint8_t *next = NULL; + janet_unmarshal(data, size, 0, reg, &next); + } + janet_restore(&tstate); + + /* cleanup Janet */ + janet_deinit(); + + return 0; +} diff --git a/test/helper.janet b/test/helper.janet index 511d8f12..7a5ce156 100644 --- a/test/helper.janet +++ b/test/helper.janet @@ -1,5 +1,8 @@ # 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) @@ -7,7 +10,7 @@ (var skip-count 0) (var skip-n 0) -(def is-verbose (os/getenv "VERBOSE")) +(var is-verbose (os/getenv "VERBOSE")) (defn- assert-no-tail "Override's the default assert with some nice error handling." @@ -19,15 +22,16 @@ (break x)) (default e "assert error") (when x (++ num-tests-passed)) - (def str (string e)) (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)) + (when is-verbose + (eprintf "\e[32m✔\e[0m %s: %s: %v" line-info (describe e) x) + (eflush) (flush)) (do - (eprintf "\e[31m✘\e[0m %s: %s: %v" line-info (string e) x) (eflush))) + (eprintf "\e[31m✘\e[0m %s: %s: %v" line-info (describe e) x) (eflush) (flush))) x) (defn skip-asserts @@ -36,7 +40,7 @@ (+= skip-n n) nil) -(defmacro assert +(defmacro assert :shadow [x &opt e] (def xx (gensym)) (default e (string/format "%j" x)) @@ -48,7 +52,12 @@ (defmacro assert-error [msg & forms] (def errsym (keyword (gensym))) - ~(assert (= ,errsym (try (do ,;forms) ([_] ,errsym))) ,msg)) + ~(as-macro ,assert (= ,errsym (try (do ,;forms) ([_] ,errsym))) ,msg)) + +(defmacro assert-error-value + [msg errval & forms] + (def e (gensym)) + ~(as-macro ,assert (= ,errval (try (do ,;forms) ([,e] ,e))) ,msg)) (defn check-compile-error [form] @@ -60,8 +69,8 @@ (def e (gensym)) (def f (gensym)) (if is-verbose - ~(try (do ,;forms (,assert true ,msg)) ([,e ,f] (,assert false ,msg) (,debug/stacktrace ,f ,e "\e[31m✘\e[0m "))) - ~(try (do ,;forms (,assert true ,msg)) ([_] (,assert false ,msg))))) + ~(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)) diff --git a/test/suite-array.janet b/test/suite-array.janet index 13e2407d..35569aaf 100644 --- a/test/suite-array.janet +++ b/test/suite-array.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -70,9 +70,9 @@ (assert (= (array/pop @[]) nil) "array/pop empty") # Code coverage -(def a @[1]) -(array/pop a) -(array/trim a) +(def a1 @[1]) +(array/pop a1) +(array/trim a1) (array/ensure @[1 1] 6 2) # array/join @@ -86,5 +86,10 @@ (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) diff --git a/test/suite-asm.janet b/test/suite-asm.janet index 075fe4e1..cd3c2dd9 100644 --- a/test/suite-asm.janet +++ b/test/suite-asm.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -21,6 +21,8 @@ (import ./helper :prefix "" :exit true) (start-suite) +(setdyn *lint-warn* :none) + # Assembly test # Fibonacci sequence, implemented with naive recursion. # a679f60 diff --git a/test/suite-boot.janet b/test/suite-boot.janet index b5909d31..df75674e 100644 --- a/test/suite-boot.janet +++ b/test/suite-boot.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -21,6 +21,8 @@ (import ./helper :prefix "" :exit true) (start-suite) +(setdyn *lint-warn* :none) + # Let # 807f981 (assert (= (let [a 1 b 2] (+ a b)) 3) "simple let") @@ -1034,4 +1036,77 @@ (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)) + +# frequencies +(assert (deep= (frequencies :lol) @{108 2 111 1})) +(assert (deep= (frequencies [:duck :duck :duck :goose]) @{:duck 3 :goose 1})) +(assert (deep= (frequencies {1 :a 2 :x 3 :x 8 :a}) @{:a 2 :x 2})) +(assert (deep= (frequencies @{}) @{})) +(assert (deep= (frequencies (coro (yield 1) (yield 8) (yield 2) (yield 8))) + @{1 1 2 1 8 2})) + +# partition-by +(assert (deep= (partition-by even? "hello") + @[@[104] @[101] @[108 108] @[111]])) +(assert (deep= (partition-by keyword? [:a "b" 'c :d]) + @[@[:a] @["b" 'c] @[:d]])) +# update +(assert (deep= (update @"hello" 0 (fn [old delta] (+ old delta)) 17) + @"yello")) +(assert (deep= (update @[:x :yy :z] 1 |(keyword (slice $ 0 1))) + @[:x :y :z])) +(assert (deep= (update @{:a 1 :b -1 :c 3} :b + 3) + @{:a 1 :b 2 :c 3})) +# distinct +(assert (deep= (distinct :hello) @[104 101 108 111])) +(assert (deep= (distinct [1 0 1 0 1 1 0 1 1 1]) @[1 0])) +(assert (deep= (distinct @{0 :a 1 :b 2 :b 3 :a}) @[:a :b])) +(assert (deep= (distinct (coro (yield 8) (yield 11) (yield 8))) @[8 11])) + +# find-index +(assert (= (find-index |(= (chr "c") $) "abc") 2)) +(assert (= (find-index |(= $ :goose) [:duck :duck :goose]) 2)) +(assert (= (find-index pos? @[-2 -1 0 -3] :surprise!) :surprise!)) +(assert (= (find-index zero? {:a 2 :b 1 :c 0}) :c)) + +# find +(assert (= (find |(= $ (chr "o")) "tomato") 111)) +(assert (= (find |(= $ (chr "m")) "potato") nil)) +(assert (= (find |(> $ (chr "y")) :ant :surprise) :surprise)) +(assert (= (find pos? [-1 0 11]) 11)) +(assert (= (find neg? @[0 1 2 3 5]) nil)) +(assert (= (find one? {:a 1 :b 2}) 1)) +(assert (= (find even? @{:x 11 :y 28 :z 33}) 28)) +(assert (= (find keyword? (coro (yield 'jump) (yield :wave))) :wave)) + +# partition +(assert (deep= (partition 2 "hello!") @["he" "ll" "o!"])) +(assert (deep= (partition 3 @"hello!") @["hel" "lo!"])) +(assert (deep= (partition 4 'hello!) @["hell" "o!"])) +(assert (deep= (partition 5 :hello!) @["hello" "!"])) +(assert (deep= (partition 2 [:ant :bee :fox :elephant]) + @[[:ant :bee] [:fox :elephant]])) +(assert (deep= (partition 3 @['rock 'paper 'scissors 'spock]) + @[['rock 'paper 'scissors] ['spock]])) +(assert (deep= (partition 2 (coro (yield 0) (yield 1) (yield 2) (yield 3))) + @[[0 1] [2 3]])) +# filter +(assert (deep= (filter |(< $ (chr "m")) "azbycw") @[97 98 99])) +(assert (deep= (filter pos? @[-1 0 1]) @[1])) +(assert (deep= (sort (filter int? {:a 1 :b 2.3 :c 3})) @[1 3])) +(assert (deep= (filter even? (coro (yield 1) (yield 2) (yield 8))) @[2 8])) + +# interpose +(assert (deep= (interpose ":" "hello") + @[104 ":" 101 ":" 108 ":" 108 ":" 111])) +(assert (deep= (interpose 0 [1 2 3]) @[1 0 2 0 3])) +(assert (deep= (interpose :goose (coro (yield :duck) (yield :duck))) + @[:duck :goose :duck])) + (end-suite) diff --git a/test/suite-buffer.janet b/test/suite-buffer.janet index 45d077b9..07c5c027 100644 --- a/test/suite-buffer.janet +++ b/test/suite-buffer.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -48,8 +48,8 @@ (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") +(def b1 @"AA") +(assert (deep= (buffer/push b1 b1) @"AAAA") "buffer/push buffer self") # buffer/push-byte (assert (deep= (buffer/push-byte @"AA" 66) @"AAB") "buffer/push-byte") @@ -145,8 +145,8 @@ # Regression #301 # a3d4ecddb -(def b (buffer/new-filled 128 0x78)) -(assert (= 38 (length (buffer/blit @"" b -1 90))) "buffer/blit 1") +(def b8 (buffer/new-filled 128 0x78)) +(assert (= 38 (length (buffer/blit @"" b8 -1 90))) "buffer/blit 1") (def a @"abcdefghijklm") (assert (deep= @"abcde" (buffer/blit @"" a -1 0 5)) "buffer/blit 2") @@ -179,5 +179,10 @@ (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) diff --git a/test/suite-bundle.janet b/test/suite-bundle.janet index 0d228cc9..8ec37c92 100644 --- a/test/suite-bundle.janet +++ b/test/suite-bundle.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -117,8 +117,17 @@ (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 "bad test" (bundle/install "./examples/sample-bad-bundle" :check true)) +(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") diff --git a/test/suite-capi.janet b/test/suite-capi.janet index dfa86fc0..7076df66 100644 --- a/test/suite-capi.janet +++ b/test/suite-capi.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 diff --git a/test/suite-cfuns.janet b/test/suite-cfuns.janet index 3e36c3f7..80a378f7 100644 --- a/test/suite-cfuns.janet +++ b/test/suite-cfuns.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 diff --git a/test/suite-compile.janet b/test/suite-compile.janet index 204a91f8..fa4d11fd 100644 --- a/test/suite-compile.janet +++ b/test/suite-compile.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -30,7 +30,7 @@ (defn myfun [x] (var a 10) (set a (do - (def y x) + (def _y x) (if x 8 9)))) (assert (= (myfun true) 8) "check do form regression") @@ -46,8 +46,10 @@ # 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") @@ -73,5 +75,121 @@ (foo 0) 10) -(end-suite) +# 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 result1 + (compile + '(defn fuzz-case-1 + [start end &] + (if end + (if e start (lazy-range (+ 1 start) end))) + 1))) +(assert (get result1 :error) "fuzz case issue #1700") + +# Issue #1702 - fuzz case with upvalues +(def result2 + (compile + '(each item [1 2 3] + # Generate a lot of upvalues (more than 224) + (def ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;out-buf @"") + (with-dyns [:out out-buf] 1)))) +(assert result2 "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 result4 (compile code (curenv) "suite-compile.janet" lints)) + (assert (and (function? result4) (empty? lints)) msg)) + +(defn check-bad-compile + [code msg] + (def lints @[]) + (def result4 (compile code (curenv) "suite-compile.janet" lints)) + (assert (not (and (function? result4) (empty? lints))) msg)) + +(defn check-lint-compile + [code msg] + (def lints @[]) + (def result4 (compile code (curenv) "suite-compile.janet" lints)) + (assert (and (function? result4) (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") + +# Variable shadowing linting +(def outer1 "a") +(check-lint-compile '(def outer1 "b") "shadow global-to-global") +(check-lint-compile '(let [outer1 "b"] outer1) "shadow local-to-global") +(check-lint-compile '(do (def x "b") (def x "c")) "shadow local-to-local") + +(check-lint-compile '(def [xxx [xxx yyy]] [1 [2 3]]) "shadow global-to-global one form") + +# Fuzz issue - odd keys +(defn f [x &keys ks] [x ks]) +(check-lint-compile + '(f 1 + = = = = = = = = = = + = = = = = = = = = = + = = = = = = = = = = + = = = = = = = = = = + = = =) + "odd keys") + +# Test for any issues with valgrind/asan +(setdyn *lint-warn* :relaxed) +(assert-no-error + "odd keys runtime" + (f 1 + = = = = = = = = = = + = = = = = = = = = = + = = = = = = = = = = + = = = = = = = = = = + = = =)) +(setdyn *lint-warn* nil) + +# Handle bad eachp +(check-good-compile '(eachp () 5) "good compile eachp 1") +(check-good-compile '(do (def [] [1]) nil) "def with empty tuple binding 1") +(check-good-compile '(do (def x (def [] [1])) x) "def with empty tuple binding 2") + +(end-suite) diff --git a/test/suite-corelib.janet b/test/suite-corelib.janet index d2a5d4d5..5c470c33 100644 --- a/test/suite-corelib.janet +++ b/test/suite-corelib.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -75,6 +75,8 @@ (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 (deep= @[] (range 10 0 0)) "range 6") +(assert (deep= @[] (range 0 10 0)) "range 7") (assert (< 1.0 nil false true (fiber/new (fn [] 1)) @@ -185,5 +187,37 @@ (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))) -(end-suite) +# 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") + +(assert-error "no infinite step range" (range 3 3 math/inf)) + +# Issue #1790 +(assert-no-error "limit short-fn parameters 1" (macex1 '|$9999)) +(assert-error "limit short-fn parameters 2" (macex1 '|$10000)) +(assert-error "limit short-fn parameters 3" (macex1 '|$10001)) +(assert-error "limit short-fn parameters 4" (macex1 '|$100010)) +(assert-error "limit short-fn parameters 5" (macex1 '|$800010)) +(assert-error "limit short-fn parameters 6" (macex1 '|$8888888888888888888888888888888888888888888888888888888888888888888888888888888)) +(assert-error "limit short-fn parameters 7" (macex1 '|$8.8)) + +(end-suite) diff --git a/test/suite-debug.janet b/test/suite-debug.janet index e0d8793d..95514710 100644 --- a/test/suite-debug.janet +++ b/test/suite-debug.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 diff --git a/test/suite-ev.janet b/test/suite-ev.janet index ead27c8e..5bc04eec 100644 --- a/test/suite-ev.janet +++ b/test/suite-ev.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose & contributors +# 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 @@ -21,6 +21,8 @@ (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")) @@ -603,4 +605,22 @@ (assert (zero? exit-code) "subprocess ran") (assert (= data "hi\nthere\n") "output is correct") +# Error handling +(assert-error "bad thread" (ev/thread in)) +(assert-error "bad thread 2" (ev/thread (fn [x y] x) 1)) + +# Exec-slurp correct error (os/spawn and the :x flag) +(defn exec-slurp + [& args] + # Close the process pipes. If the process pipes are not closed, janet can run out of file descriptors. + (with [proc (os/spawn args :xp {:out :pipe})] + (let [[out] (ev/gather + (ev/read (proc :out) :all) + (os/proc-wait proc))] + (if out (string/trimr out) "")))) +(def [ok msg] (protect (exec-slurp ;run janet "-e" "(os/exit 1)"))) +(assert (not ok) "os/spawn :x 1") +(assert (not (string/has-prefix? "cannot cancel" msg)) "os/spawn :x 2") +(assert (string/has-prefix? "command failed" msg) "os/spawn :x 3") + (end-suite) diff --git a/test/suite-ev2.janet b/test/suite-ev2.janet index 1d774b85..24a2e0c8 100644 --- a/test/suite-ev2.janet +++ b/test/suite-ev2.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose & contributors +# 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 @@ -43,9 +43,9 @@ (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 [] +(def thread-channel :shadow (ev/thread-chan 100)) +(def super :shadow (ev/thread-chan 10)) +(defn worker :shadow [] (while true (def item (ev/take thread-channel)) (when (= item :deadline) @@ -55,4 +55,50 @@ (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)) + +# IO file copying +(os/mkdir "tmp") +(def f-original (file/open "tmp/out.txt" :wb)) +(xprin f-original "hello\n") +(file/flush f-original) +(ev/do-thread + # Closes a COPY of the original file, otherwise we get a user-after-close file descriptor + (:close f-original)) +(def g-original (file/open "tmp/out2.txt" :wb)) +(xprin g-original "world1\n") +(xprin f-original "world2\n") +(:close f-original) +(xprin g-original "abc\n") +(:close g-original) +(assert (deep= @"hello\nworld2\n" (slurp "tmp/out.txt")) "file threading 1") +(assert (deep= @"world1\nabc\n" (slurp "tmp/out2.txt")) "file threading 2") + (end-suite) diff --git a/test/suite-ffi.janet b/test/suite-ffi.janet index c6237736..73e8e07a 100644 --- a/test/suite-ffi.janet +++ b/test/suite-ffi.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose & contributors +# 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 @@ -21,7 +21,7 @@ (import ./helper :prefix "" :exit true) (start-suite) -(def has-ffi (dyn 'ffi/native)) +(var has-ffi (dyn 'ffi/native)) (def has-full-ffi (and has-ffi (when-let [entry (dyn 'ffi/calling-conventions)] diff --git a/test/suite-filewatch.janet b/test/suite-filewatch.janet index 9c3f7404..c8f9f19d 100644 --- a/test/suite-filewatch.janet +++ b/test/suite-filewatch.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose & contributors +# 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 @@ -24,8 +24,10 @@ (assert true) (def chan (ev/chan 1000)) -(def is-win (or (= :mingw (os/which)) (= :windows (os/which)))) -(def is-linux (= :linux (os/which))) +(var is-win (or (= :mingw (os/which)) (= :windows (os/which)))) +(var is-linux (= :linux (os/which))) +(def bsds [:freebsd :macos :openbsd :bsd :dragonfly :netbsd]) +(var is-kqueue (index-of (os/which) bsds)) # If not supported, exit early (def [supported msg] (protect (filewatch/new chan))) @@ -97,6 +99,10 @@ (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)) +(when is-kqueue + (filewatch/add fw (string td3 "/file3.txt") :all) + (filewatch/add fw td1 :all) + (filewatch/add fw td2 :all)) (assert-no-error "filewatch/listen no error" (filewatch/listen fw)) # @@ -196,6 +202,30 @@ (expect-empty) (gccollect)) +# +# Macos and BSD file writing +# + +# TODO - kqueue capabilities here are a bit more limited than inotify and windows by default. +# This could be ammended with some heavier-weight functionality in userspace, though. +(when is-kqueue + (spit-file td1 "file1.txt") + (expect :wd-path td1 :type :write) + (expect-empty) + (gccollect) + (spit-file td1 "file1.txt") + # Currently, only operations that modify the parent vnode do anything + (expect-empty) + (gccollect) + # Check that we don't get anymore events from test directory 2 + (spit-file td2 "file2.txt") + (expect :wd-path td2 :type :write) + (expect-empty) + # Remove a file, then wait for remove event + (rmrf (string td1 "/file1.txt")) + (expect :type :write) # a "write" to the vnode + (expect-empty)) + (assert-no-error "filewatch/unlisten no error" (filewatch/unlisten fw)) (assert-no-error "cleanup 1" (rmrf td1)) (assert-no-error "cleanup 2" (rmrf td2)) diff --git a/test/suite-inttypes.janet b/test/suite-inttypes.janet index 91b38590..529be503 100644 --- a/test/suite-inttypes.janet +++ b/test/suite-inttypes.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose & contributors +# 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 @@ -21,6 +21,9 @@ (import ./helper :prefix "" :exit true) (start-suite) +# Disable linting warnings +(setdyn *lint-warn* :none) + # some tests for bigint # 319575c (def i64 int/s64) diff --git a/test/suite-io.janet b/test/suite-io.janet index 726b7aa4..23672f62 100644 --- a/test/suite-io.janet +++ b/test/suite-io.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose & contributors +# 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 @@ -37,7 +37,7 @@ # Printing to functions # 4e263b8c3 -(def out-buf @"") +(def out-buf :shadow @"") (defn prepend [x] (with-dyns [:out out-buf] (prin "> " x))) @@ -59,8 +59,8 @@ # issue #1055 - 2c927ea76 (let [b @""] - (defn dummy [a b c] - (+ a b c)) + (defn dummy [a bb c] + (+ a bb c)) (trace dummy) (defn errout [arg] (buffer/push b arg)) diff --git a/test/suite-marsh.janet b/test/suite-marsh.janet index 9defbc55..b4fdacba 100644 --- a/test/suite-marsh.janet +++ b/test/suite-marsh.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -81,10 +81,12 @@ "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") @@ -93,11 +95,11 @@ (do (defn f1 [a] - (defn f1 [] (++ (a 0))) + (defn f1 :shadow [] (++ (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)) + (def [f1 f2] :shadow (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")) @@ -106,10 +108,10 @@ (do (defn f1 [a] - (defn f1 [] (++ (a 0))) - (defn f2 [] (++ (a 0))) + (defn f1 :shadow [] (++ (a 0))) + (defn f2 :shadow [] (++ (a 0))) (marshal [f1 f2] make-image-dict)) - (def [f1 f2] (unmarshal (f1 @[0]) load-image-dict)) + (def [f1 f2] :shadow (unmarshal (f1 @[0]) load-image-dict)) (assert (= 1 (f1)) "marshal-live-closure 1") (assert (= 2 (f2)) "marshal-live-closure 2")) @@ -187,11 +189,11 @@ neldb\0\0\0\xD8\x05printG\x01\0\xDE\xDE\xDE'\x03\0marshal_tes/\x02 (assert (deep= t tclone) "table/weak marsh 7") # table weak keys -(def t (table/weak-keys 1)) +(def t :shadow (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)) +(def tclone :shadow (-> t marshal unmarshal)) (assert (= 2 (length tclone)) "table/weak-keys marsh 2") (gccollect) (assert (= 1 (length tclone)) "table/weak-keys marsh 3") @@ -199,23 +201,23 @@ neldb\0\0\0\xD8\x05printG\x01\0\xDE\xDE\xDE'\x03\0marshal_tes/\x02 (assert (deep= t tclone) "table/weak-keys marsh 5") # table weak values -(def t (table/weak-values 1)) +(def t :shadow (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)) +(def tclone :shadow (-> 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)) +(def t :shadow (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)) +(def tclone :shadow (-> t marshal unmarshal)) (assert (= 2 (length tclone)) "marsh weak tables with prototypes 2") (gccollect) (assert (= 1 (length t)) "marsh weak tables with prototypes 3") diff --git a/test/suite-math.janet b/test/suite-math.janet index 58b4ff18..338bc7cf 100644 --- a/test/suite-math.janet +++ b/test/suite-math.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -31,13 +31,13 @@ [rng] (assert (all identity (seq [i :range [0 1000]] (<= (math/rng-int rng i) i))) "math/rng-int test") - (assert (all identity (seq [i :range [0 1000]] + (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 i 0 75 +(for _ 0 75 (test-rng (math/rng (:int seedrng)))) # 70328437f @@ -49,7 +49,7 @@ # 027b2a8 (defn assert-many [f n e] (var good true) - (loop [i :range [0 n]] + (loop [_ :range [0 n]] (if (not (f)) (set good false))) (assert good e)) diff --git a/test/suite-net.janet b/test/suite-net.janet new file mode 100644 index 00000000..86433168 --- /dev/null +++ b/test/suite-net.janet @@ -0,0 +1,35 @@ +# 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) diff --git a/test/suite-os.janet b/test/suite-os.janet index 40e62bfd..965dff1a 100644 --- a/test/suite-os.janet +++ b/test/suite-os.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -63,7 +63,10 @@ "strftime january 2014") (assert (= (try (os/strftime "%%%d%t") ([err] err)) "invalid conversion specifier '%t'") - "invalid conversion specifier") + "invalid conversion specifier 1") +(assert (= (try (os/strftime "%H:%M:%") ([err] err)) + "invalid conversion specifier") + "invalid conversion specifier 2") # 07db4c530 (os/setenv "TESTENV1" "v1") @@ -143,6 +146,14 @@ (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, SystemRoot, etc. and so fails +# Also fails for address sanitizer builds on windows. +(def result (os/execute [;run janet "-e" "(+ 1 2 3)"] :pe {})) +(assert (or (= result -1073741515) (= result 0)) + "os/execute with minimal env") + # os/execute regressions # 427f7c362 (for i 0 10 @@ -165,4 +176,27 @@ :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) diff --git a/test/suite-parse.janet b/test/suite-parse.janet index 1cb3c71a..aff86fda 100644 --- a/test/suite-parse.janet +++ b/test/suite-parse.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -67,7 +67,7 @@ (def str (if rewrite (peg/replace-all ~(* '(* (? "\r") "\n") (between 0 ,indent " ")) - (fn [mtch eol] eol) text) + (fn [_mtch eol] eol) text) text)) (def first-eol (cond @@ -138,13 +138,13 @@ # Parser clone # 43520ac67 -(def p (parser/new)) -(assert (= 7 (parser/consume p "(1 2 3 ")) "parser 1") -(def p2 (parser/clone p)) +(def p0 (parser/new)) +(assert (= 7 (parser/consume p0 "(1 2 3 ")) "parser 1") +(def p2 (parser/clone p0)) (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/consume p0 ") 1 ") +(assert (deep= (parser/status p0) (parser/status p2)) "parser 2") +(assert (deep= (parser/state p0) (parser/state p2)) "parser 3") # Parser errors # 976dfc719 @@ -177,13 +177,13 @@ (def p1 (parser/new)) (parser/state p1) (parser/consume p1 step1) -(loop [v :iterate (parser/produce p1)]) +(loop [_ :iterate (parser/produce p1)]) (parser/state p1) -(def p2 (parser/clone p1)) -(parser/state p2) -(parser/consume p2 step2) -(loop [v :iterate (parser/produce p2)]) -(parser/state p2) +(def p3 (parser/clone p1)) +(parser/state p3) +(parser/consume p3 step2) +(loop [_ :iterate (parser/produce p3)]) +(parser/state p3) # parser delimiter errors (defn test-error [delim fmt] @@ -202,11 +202,11 @@ (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"])) +(def p4 (parser/new)) +(parser/consume p4 `("hel`) +(parser/insert p4 `lo`) +(parser/consume p4 `")`) +(assert (= (parser/produce p4) ["hello"])) # Hex floats (assert (= math/pi +0x1.921fb54442d18p+0001)) diff --git a/test/suite-peg.janet b/test/suite-peg.janet index cf7e86d6..0058e490 100644 --- a/test/suite-peg.janet +++ b/test/suite-peg.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -84,10 +84,10 @@ # Substitution test with peg # d7626f8c5 -(def grammar '(accumulate (any (+ (/ "dog" "purple panda") (<- 1))))) +(def grammar1 '(accumulate (any (+ (/ "dog" "purple panda") (<- 1))))) (defn try-grammar [text] (assert (= (string/replace-all "dog" "purple panda" text) - (0 (peg/match grammar text))) text)) + (0 (peg/match grammar1 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.") @@ -101,9 +101,9 @@ # 798c88b4c (def csv '{:field (+ - (* `"` (% (any (+ (<- (if-not `"` 1)) - (* (constant `"`) `""`)))) `"`) - (<- (any (if-not (set ",\n") 1)))) + (* `"` (% (any (+ (<- (if-not `"` 1)) + (* (constant `"`) `""`)))) `"`) + (<- (any (if-not (set ",\n") 1)))) :main (* :field (any (* "," :field)) (+ "\n" -1))}) (defn check-csv @@ -266,6 +266,12 @@ (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 @@ -330,7 +336,7 @@ # unref # 96513665d -(def grammar +(def grammar2 (peg/compile ~{:main (* :tagged -1) :tagged (unref (replace (* :open-tag :value :close-tag) ,struct)) @@ -338,23 +344,23 @@ :value (* (constant :value) (group (any (+ :tagged :untagged)))) :close-tag (* "") :untagged (capture (any (if-not "<" 1)))})) -(check-deep grammar "

foobar

" +(check-deep grammar2 "

foobar

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

foobar

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

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}) + '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)) @@ -363,7 +369,7 @@ (def sym (symbol text)) [(if (or (root-env sym) (specials sym)) :coresym :symbol) text]) -(def grammar +(def grammar3 ~{:ws (set " \v\t\r\f\n\0") :readermac (set "';~,") :symchars (+ (range "09" "AZ" "az" "\x80\xFF") @@ -399,16 +405,16 @@ :struct (* '"{" :root2 (+ '"}" (error ""))) :parray (* '"@" :ptuple) :barray (* '"@" :btuple) - :dict (* '"@" :struct) + :dict (* '"@" :struct) :main (+ :root (error ""))}) -(def p (peg/compile grammar)) +(def porig (peg/compile grammar3)) # Just make sure is valgrind clean. -(def p (-> p make-image load-image)) +(def pprime (-> porig 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") +(assert (peg/match pprime "abc") "complex peg grammar 1") +(assert (peg/match pprime "[1 2 3 4]") "complex peg grammar 2") ### ### Compiling brainfuck to Janet. @@ -559,22 +565,22 @@ "peg/replace-all function") # 9dc7e8ed3 -(defn peg-test [name f peg subst text expected] - (assert (= (string (f peg subst text)) expected) name)) +(defn peg-test [name f pegg subst text expected] + (assert (= (string (f pegg 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/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/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 @@ -596,10 +602,10 @@ # 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") +(def p3 (-> "abcd" peg/compile marshal unmarshal)) +(assert (peg/match p3 "abcd") "peg marshal 1") +(assert (peg/match p3 "abcdefg") "peg marshal 2") +(assert (not (peg/match p3 "zabcdefg")) "peg marshal 3") # to/thru bug # issue #971 - a895219d2 @@ -648,164 +654,164 @@ # issue #1026 - 9341081a4 (assert (deep= - (peg/match '(not (* (constant 7) "a")) "hello") - @[]) "peg not") + (peg/match '(not (* (constant 7) "a")) "hello") + @[]) "peg not") (assert (deep= - (peg/match '(if-not (* (constant 7) "a") "hello") "hello") - @[]) "peg if-not") + (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") + (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") + (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)) +(defn test [name pegg input expected] + (assert-no-error "compile peg" (peg/compile pegg)) + (assert-no-error "marshal/unmarshal peg" (-> pegg marshal unmarshal)) + (assert (deep= (peg/match pegg input) expected) name)) (test "sub: matches the same input twice" - ~(sub "abcd" "abc") - "abcdef" - @[]) + ~(sub "abcd" "abc") + "abcdef" + @[]) (test "sub: second pattern cannot match more than the first pattern" - ~(sub "abcd" "abcde") - "abcdef" - nil) + ~(sub "abcd" "abcde") + "abcdef" + nil) (test "sub: fails if first pattern fails" - ~(sub "x" "abc") - "abcdef" - nil) + ~(sub "x" "abc") + "abcdef" + nil) (test "sub: fails if second pattern fails" - ~(sub "abc" "x") - "abcdef" - nil) + ~(sub "abc" "x") + "abcdef" + nil) (test "sub: keeps captures from both patterns" - ~(sub '"abcd" '"abc") - "abcdef" - @["abcd" "abc"]) + ~(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"]) + ~(* (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" - @[]) + ~(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]) + ~(* "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" - @[]) + ~(* (sub "abc" "ab") "d") + "abcdef" + @[]) (test "til: basic matching" - ~(til "d" "abc") - "abcdef" - @[]) + ~(til "d" "abc") + "abcdef" + @[]) (test "til: second pattern can't see past the first occurrence of first pattern" - ~(til "d" (* "abc" -1)) - "abcdef" - @[]) + ~(til "d" (* "abc" -1)) + "abcdef" + @[]) (test "til: fails if first pattern fails" - ~(til "x" "abc") - "abcdef" - nil) + ~(til "x" "abc") + "abcdef" + nil) (test "til: fails if second pattern fails" - ~(til "abc" "x") - "abcdef" - nil) + ~(til "abc" "x") + "abcdef" + nil) (test "til: discards captures from initial pattern" - ~(til '"d" '"abc") - "abcdef" - @["abc"]) + ~(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]) + ~(* "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" - @[]) + ~(* (til "d" "ab") "e") + "abcdef" + @[]) (test "split: basic functionality" - ~(split "," '1) - "a,b,c" - @["a" "b" "c"]) + ~(split "," '1) + "a,b,c" + @["a" "b" "c"]) (test "split: drops captures from separator pattern" - ~(split '"," '1) - "a,b,c" - @["a" "b" "c"]) + ~(split '"," '1) + "a,b,c" + @["a" "b" "c"]) (test "split: can match empty subpatterns" - ~(split "," ':w*) - ",a,,bar,,,c,," - @["" "a" "" "bar" "" "" "c" "" ""]) + ~(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"]) + ~(split "," '(to -1)) + "a,,bar,c" + @["a" "" "bar" "c"]) (test "split: fails if any subpattern fails" - ~(split "," '"a") - "a,a,b" - nil) + ~(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"]) + ~(split "x" '(to -1)) + "a,a,b" + @["a,a,b"]) (test "split: always consumes entire input" - ~(split 1 '"") - "abc" - @["" "" "" ""]) + ~(split 1 '"") + "abc" + @["" "" "" ""]) (test "split: separator can be an arbitrary PEG" - ~(split :s+ '(to -1)) - "a b c" - @["a" "b" "c"]) + ~(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"]) + ~(* (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"]) + ~{: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"]) + ~{: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" @@ -814,9 +820,9 @@ nil) (test "issue 1539 pt. 2" - ~(split "," (capture 0)) - "abc123,,,," - @["" "" "" "" ""]) + ~(split "," (capture 0)) + "abc123,,,," + @["" "" "" "" ""]) # Issue #1549 - allow buffers as peg literals (test "issue 1549" @@ -835,5 +841,116 @@ (test "issue 1554 case 8" '(between 2 3 (? (> '1))) "abc" @["a" "a" "a"]) (test "issue 1554 case 9" '(between 0 0 (> (? '1))) "abc" @[]) -(end-suite) +# 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 pegg input expected-matches expected-stderr] + (with-dyns [:err @""] + (test name pegg input expected-matches)) + (def actual @"") + (with-dyns [:err actual *err-color* true] + (peg/match pegg input)) + (assert (deep= (string actual) expected-stderr))) + +(defn test-stderr-no-color [name pegg input expected-matches expected-stderr] + (with-dyns [:err @""] + (test name pegg input expected-matches)) + (def actual @"") + (with-dyns [:err actual *err-color* false] + (peg/match pegg 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) diff --git a/test/suite-pp.janet b/test/suite-pp.janet index 4030d64f..a75ba482 100644 --- a/test/suite-pp.janet +++ b/test/suite-pp.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose & contributors +# 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 @@ -44,8 +44,8 @@ (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)) +(def buftemp2 @"abcd") +(assert (= (string (buffer/format buftemp2 "---%p %p---" buftemp2 buftemp2)) `abcd---@"abcd" @"abcd"---`) "buffer/format on self 2") # 5c364e0 @@ -61,5 +61,86 @@ (check-jdn "a string") (check-jdn @"a buffer") -(end-suite) +# Issue 1737 +(assert (deep= "@[]" (string/format "%M" @[]))) +(assert (deep= " @[]" (string/format " %M" @[]))) +(assert (deep= " @[]" (string/format " %M" @[]))) +(assert (deep= " @[]" (string/format " %M" @[]))) +(assert (deep= " @[]" (string/format " %M" @[]))) +(assert (deep= " @[]" (string/format " %M" @[]))) +(assert (deep= "@[1]" (string/format "%m" @[1]))) +(assert (deep= " @[2]" (string/format " %m" @[2]))) +(assert (deep= " @[3]" (string/format " %m" @[3]))) +(assert (deep= " @[4]" (string/format " %m" @[4]))) +(assert (deep= " @[5]" (string/format " %m" @[5]))) +(assert (deep= " @[6]" (string/format " %m" @[6]))) +# Test multiline pretty specifiers +(let [tup [:keyword "string" @"buffer"] + tab @{true (table/setproto @{:bar tup + :baz 42} + @{:_name "Foo"})}] + (set (tab tup) tab) + (assert (= (string/format "%67m" {tup @[tup tab] 'symbol tup}) + ` +{symbol (:keyword "string" @"buffer") + (:keyword + "string" + @"buffer") @[(:keyword "string" @"buffer") + @{true @Foo{:bar (:keyword "string" @"buffer") + :baz 42} + (:keyword "string" @"buffer") }]}`)) + (assert (= (string/format "%67p" {(freeze (zipcoll (range 42) + (range -42 0))) tab}) + ` +{{0 -42 + 1 -41 + 2 -40 + 3 -39 + 4 -38 + 5 -37 + 6 -36 + 7 -35 + 8 -34 + 9 -33 + 10 -32 + 11 -31 + 12 -30 + 13 -29 + 14 -28 + 15 -27 + 16 -26 + 17 -25 + 18 -24 + 19 -23 + 20 -22 + 21 -21 + 22 -20 + 23 -19 + 24 -18 + 25 -17 + 26 -16 + 27 -15 + 28 -14 + 29 -13 + ...} @{true @Foo{:bar (:keyword "string" @"buffer") :baz 42} + (:keyword "string" @"buffer") }}`))) + +# Issue 1737 +(def capture-buf @"") +(with-dyns [*err* capture-buf] + (peg/match ~(* (constant @[]) (??)) "a")) +(assert (deep= ``` + ?? at [a] (index 0) + stack [1]: + [0]: @[] + + ``` + (string capture-buf))) + +(assert (= + (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 {} @[]) + "?? at [bc] (index 2)\nstack [5]:\n [0]: \"a\"\n [1]: 1\n [2]: true\n [3]: {}\n [4]: @[]\n") + "pretty format should not eat explicit newlines") + +(end-suite) diff --git a/test/suite-specials.janet b/test/suite-specials.janet index edabf8c3..4532f885 100644 --- a/test/suite-specials.janet +++ b/test/suite-specials.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -21,6 +21,9 @@ (import ./helper :prefix "" :exit true) (start-suite) +# Disable linting warnings +(setdyn *lint-warn* :none) + # Regression Test #137 # affcb5b45 (def [a b c] (range 10)) diff --git a/test/suite-string.janet b/test/suite-string.janet index a92b0eb6..a7cd7e4c 100644 --- a/test/suite-string.janet +++ b/test/suite-string.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 diff --git a/test/suite-strtod.janet b/test/suite-strtod.janet index d14985b9..99685ef7 100644 --- a/test/suite-strtod.janet +++ b/test/suite-strtod.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 diff --git a/test/suite-struct.janet b/test/suite-struct.janet index 3178a9e2..48fe6800 100644 --- a/test/suite-struct.janet +++ b/test/suite-struct.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 diff --git a/test/suite-symcache.janet b/test/suite-symcache.janet index 29b6c541..7f0c98f6 100644 --- a/test/suite-symcache.janet +++ b/test/suite-symcache.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 diff --git a/test/suite-table.janet b/test/suite-table.janet index 4f954778..f261c678 100644 --- a/test/suite-table.janet +++ b/test/suite-table.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 diff --git a/test/suite-tuple.janet b/test/suite-tuple.janet index f2010080..a83e0f81 100644 --- a/test/suite-tuple.janet +++ b/test/suite-tuple.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 diff --git a/test/suite-unknown.janet b/test/suite-unknown.janet index f35d3ab4..926356de 100644 --- a/test/suite-unknown.janet +++ b/test/suite-unknown.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -21,6 +21,9 @@ (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 diff --git a/test/suite-value.janet b/test/suite-value.janet index 16a6d455..25070583 100644 --- a/test/suite-value.janet +++ b/test/suite-value.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 diff --git a/test/suite-vm.janet b/test/suite-vm.janet index e1019379..8ffdcd3a 100644 --- a/test/suite-vm.janet +++ b/test/suite-vm.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2025 Calvin Rose +# 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 @@ -64,11 +64,11 @@ # 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))) +(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))) +(assert (= :bad (try ((identity :ok) @{:ok 2} :no) ([_err] :bad))) "calling keyword too many arguments") -(assert (= :oops (try ((+ 2 -1) 1) ([err] :oops))) +(assert (= :oops (try ((+ 2 -1) 1) ([_err] :oops))) "calling number fails") # Method test @@ -119,7 +119,7 @@ (with-dyns [] (ev/sleep 0) (error "oops"))) - ([err] :caught)))) + ([_err] :caught)))) "regression #638")) # @@ -132,11 +132,11 @@ # 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") +(def fc (fiber/new (fn [&] (yield 1) (yield 2) (yield 3) 4) :yti)) +(assert (= 1 (resume fc)) "cancel resume 1") +(assert (= 2 (resume fc)) "cancel resume 2") +(assert (= :hi (cancel fc :hi)) "cancel resume 3") +(assert (= :error (fiber/status fc)) "cancel resume 4") (end-suite) diff --git a/tools/afl/pp_runner.janet b/tools/afl/pp_runner.janet new file mode 100644 index 00000000..3e87a886 --- /dev/null +++ b/tools/afl/pp_runner.janet @@ -0,0 +1,7 @@ +(def p (parser/new)) +(parser/consume p (slurp ((dyn :args) 1))) +(while (parser/has-more p) + (def x (parser/produce p)) + (printf "%m\n%99M\n%1m\n%0M" x x x x) + (printf "%q\n%99Q\n%1p\n%P" x x x x) + (protect (printf "%j" x))) diff --git a/tools/msi/LICENSE.rtf b/tools/msi/LICENSE.rtf index 24a86b77..8a6be5e5 100644 Binary files a/tools/msi/LICENSE.rtf and b/tools/msi/LICENSE.rtf differ diff --git a/tools/msi/janet.wxs b/tools/msi/janet.wxs index d14cfa5a..5269806f 100644 --- a/tools/msi/janet.wxs +++ b/tools/msi/janet.wxs @@ -87,7 +87,9 @@ - + + + @@ -169,6 +171,7 @@ ALLUSERS=1 + @@ -178,6 +181,7 @@ NOT ALLUSERS=1 + diff --git a/tools/symcharsgen.c b/tools/symcharsgen.c index 8193cd5c..3908ce1b 100644 --- a/tools/symcharsgen.c +++ b/tools/symcharsgen.c @@ -1,5 +1,5 @@ /* -* Copyright (c) 2025 Calvin Rose +* 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