1
0
mirror of https://github.com/janet-lang/janet synced 2025-10-28 22:27:41 +00:00

Compare commits

..

332 Commits

Author SHA1 Message Date
Calvin Rose
fbb0711ae1 Distinguish between subprocess when testing. 2023-06-24 12:07:55 -05:00
Calvin Rose
676b233566 Hack for qemu based testing (also should work with valgrind) 2023-06-24 11:59:17 -05:00
Calvin Rose
d7431c7cdb Revert "Test removing 32bit ptr marshalling."
This reverts commit 566b45ea44.
2023-06-24 11:54:04 -05:00
Calvin Rose
566b45ea44 Test removing 32bit ptr marshalling. 2023-06-24 11:52:22 -05:00
Calvin Rose
ff2f71d2bc Conditionally compile marshal_ptr code. 2023-06-24 11:42:10 -05:00
Calvin Rose
bd420aeb0e Add range checking to bit-shift code to prevent undefined behavior. 2023-06-24 11:38:34 -05:00
Calvin Rose
b738319f8d Remove range check on 32 bit arch since it will always pass. 2023-06-24 11:17:30 -05:00
Calvin Rose
7248626235 Quiet some build warnings. 2023-06-24 10:56:45 -05:00
Calvin Rose
141c1de946 Add marshal utilities for pointers. 2023-06-24 10:50:13 -05:00
Calvin Rose
c2d77d6720 Merge branch 'master' into armtest 2023-06-24 10:40:35 -05:00
Calvin Rose
ff90b81ec3 Add some utilitites for dealing with unsigned integers in janet.h 2023-06-24 10:38:35 -05:00
Calvin Rose
9120eaef79 Merge pull request #1201 from pyrmont/bugfix.dup-fds
Avoid prematurely closing file descriptors when redirecting IO
2023-06-24 09:51:34 -05:00
Michael Camilleri
1ccd879916 Make test cross-platform 2023-06-24 10:56:47 +09:00
Michael Camilleri
f977ace7f8 Avoid prematurely closing file descriptors when redirecting IO 2023-06-23 15:50:19 +09:00
Calvin Rose
c3f4dc0c15 Merge pull request #1200 from sogaiu/use-vm_commit
Use vm_commit
2023-06-22 20:40:03 -05:00
sogaiu
78eed9b11c Use vm_commit 2023-06-22 21:36:57 +09:00
Calvin Rose
3a4d56afca Patch release. 2023-06-19 07:18:35 -05:00
Calvin Rose
63bb93fc07 Fix isatty code to not use functions only defined if ev is enabled. 2023-06-19 07:14:56 -05:00
Calvin Rose
5a39a04a79 Prepare for 1.29.0 release. 2023-06-19 06:48:33 -05:00
Calvin Rose
2fde34b519 Remove extra function call that cannot ever trigger. 2023-06-18 09:41:53 -05:00
Calvin Rose
1ef5c038db Merge pull request #1187 from CosmicToast/peg-boolean
peg: add support for "true" and "false" primitives to always/never match
2023-06-18 09:40:46 -05:00
Calvin Rose
e2459cfb47 Merge pull request #1185 from chris-chambers/macro-lints-fix
Fix order in which *macro-lints* is set during expansion
2023-06-18 09:39:25 -05:00
Calvin Rose
cfffc0bcf1 Merge pull request #1190 from primo-ppcg/if-let
update if-let
2023-06-18 09:38:44 -05:00
Ico Doornekamp
677b8a6f32 Added ARM32 test 2023-06-12 21:02:51 +02:00
Calvin Rose
7272f43191 Merge pull request #1188 from primo-ppcg/if-let 2023-06-11 07:21:38 -05:00
primo-ppcg
2a7ea27bb7 do not expand false branch more than once
Fixes #1191
2023-06-11 19:15:48 +07:00
primo-ppcg
32c5b816ae use unquotes instead 2023-06-11 18:38:20 +07:00
Chloe Kudryavtsev
e54ea7a1d8 fixup! peg: add support for "true" and "false" primitives to always/never match 2023-06-11 12:38:40 +02:00
primo-ppcg
1077efd03a update if-let
Fixes #1189
2023-06-11 17:19:29 +07:00
Chloe Kudryavtsev
f9ab91511d peg: add support for "true" and "false" primitives to always/never match
The use cases involve user-expandable grammars.
For example, consider the IRC nickname specification.
> They SHOULD NOT contain any dot character ('.', 0x2E).
> Servers MAY have additional implementation-specific nickname restrictions.

To implement this, we can do something along these lines:
```janet
(def nickname @{:main '(some :allowed)
                :allowed (! (+ :forbidden/dot :forbidden/user))
	        # for lax mode, (put nickname :forbidden/dot false)
	        :forbidden/dot "."
		# to add your own requirements
		# (put nickname :forbidden/user 'something)
		:forbidden/user false})
```

Additionally, it's common in parsing theory to allow matches of the
empty string (epsilon). `true` essentially allows for this.

Note that this does not strictly add new functionality, you could
emulate this previously using `0` and `(! 0)` respectively, but this
should be faster and more intuitive.
The speed improvement primarily comes from `(! 0)` which is now a single
step.
2023-06-11 10:44:39 +02:00
primo-ppcg
2c3ca2984e simplify if-let logic 2023-06-11 12:09:58 +07:00
primo-ppcg
94722e566c if-let better test coverage 2023-06-11 12:07:13 +07:00
Christopher Chambers
163f7ee85d Add test for maclintf in nested macro invocations 2023-06-10 16:52:20 -04:00
Christopher Chambers
52d3470cbe Fix order in which *macro-lints* is set during expansion
Previously, `*macro-lints*` was set after the `macroexpand1` fiber was
resumed, rather than just before.  And, `*macro-lints*` was never
cleared.  This behavior was typically fine since the main users of
`compile` pass the same lint array repeatedly, and the first macro
expansion (somewhere in boot.janet) never produces a lint.  But, when
compiling with a fresh lint array, if the first macro invocation
produced a lint, the lint was always lost.
2023-06-09 12:53:10 -04:00
Calvin Rose
0bd6e85c61 update changelog 2023-06-08 19:54:01 -05:00
Calvin Rose
e35c6b876f Merge pull request #1183 from primo-ppcg/take-drop
Make take and drop more symmetric
2023-06-08 14:52:51 -05:00
Calvin Rose
9a2897e741 Run through astyle with manual corrections 2023-06-08 13:01:49 -05:00
primo-ppcg
70b2e8179d nitpick performance tweak 2023-06-08 23:57:07 +07:00
primo-ppcg
5317edc65d minor readability change
As suggested by @sogaiu

@zevv forget to push this change in a recent PR (https://github.com/janet-lang/janet/pull/1175#issuecomment-1576128152).

Incidentally, the affected lines were already reformatted in the current PR, via fmt/format-file.
2023-06-08 23:00:05 +07:00
Calvin Rose
866d83579e Address #1165 - Allow for partial ffi support without totally removing testing.
Query at runtime which calling conventions are supported, including
a placeholder :none.
2023-06-08 09:07:16 -05:00
primo-ppcg
a238391b36 take-drop performance tweaks
Increase efficiency for `take` and `drop` with slices.
Check indexed types before bytes types.
2023-06-08 14:50:37 +07:00
Calvin Rose
5e152d30db Merge pull request #1182 from chris-chambers/channel-close-resumptions 2023-06-07 17:15:45 -05:00
Christopher Chambers
57c954783d Fix resumption values when closing a channel.
When suspended in `ev/give` or `ev/take`, closing the channel should
cause the result of `ev/give` or `ev/take` to be `nil`.

When suspended in `ev/select`, closing the channel should cause the
result of `ev/select` to be `[:close ch]`.

The results were flipped before.
2023-06-07 15:01:56 -04:00
primo-ppcg
b5407ac708 take-drop dictionaries
Return table for `take` of dictionary types.
Allow `drop` of dictionary types.
2023-06-07 19:20:05 +07:00
primo-ppcg
472ec730b5 take-drop symmetry
Allow `take` from the end of bytes or indexed (as `drop` does).
Allow `drop` from fibers (as `take` does).
2023-06-07 18:12:36 +07:00
Calvin Rose
8c819b1f91 Update README.md 2023-06-05 12:55:08 -05:00
Calvin Rose
528a516390 Add more sandbox capabilities.
Add more granularity to ffi sandbox capabilities - distinguish between
using FFI functions, creating FFI functions, and creating executable
memory.
2023-06-04 18:48:34 -05:00
Calvin Rose
6509e37c84 Update CHANGELOG.md and README.md 2023-06-04 16:11:17 -05:00
Calvin Rose
649173f661 Merge pull request #1175 from zevv/quicky
Added JANET_NO_AMALG flag to Makefile
2023-06-04 14:24:35 -05:00
Calvin Rose
1efb0adb35 Add 3 argument form to fiber/new
Allow passing in environment table at fiber creation since
it is a fairly common thing to do.
2023-06-04 14:17:18 -05:00
Calvin Rose
88a8e2c1df Define *task-id* since it is part of the event-loop runtime. 2023-06-04 14:05:37 -05:00
Ico Doornekamp
bb4ff05d35 Added NO_AMALG flag to Makefile to build janet from the individual
source files instead of from the amalgamated janet.c; this considerably
speeds up parallel builds on modern CPUs
2023-06-04 20:02:47 +02:00
Calvin Rose
dd3b601c87 Don't do fiber double arity check. 2023-06-04 12:56:03 -05:00
Calvin Rose
e22d101a62 Merge pull request #1179 from zevv/zevv-tests
Added misc tests to increase test coverage
2023-06-04 12:53:43 -05:00
Calvin Rose
4b3c813f5a Revert to old behavior of janet_fiber returning NULL.
When there is a bad arity function passed in to the fiber
constructor, return NULL so the runtime can choose what to do.
This is not the prettiest API but does work, and gives better error
messages for instance in the compiler.
2023-06-04 11:21:52 -05:00
Calvin Rose
67f375bea2 Small code style change to boot.janet 2023-06-04 11:10:39 -05:00
Calvin Rose
88ba99b87e Merge pull request #1181 from chris-chambers/ev-gather-cancel
Ensure ev/gather fibers are fully canceled on error
2023-06-04 11:10:24 -05:00
Christopher Chambers
53447e9d0b Ensure ev/gather fibers are fully canceled on error. 2023-06-04 10:49:30 -04:00
Calvin Rose
c4c86f8671 Run boot.janet through janet-format. 2023-06-03 16:47:59 -05:00
Calvin Rose
658941d26d Fix macro declaration. 2023-06-03 14:24:41 -05:00
Calvin Rose
e4bf27b01c Macro hack for meson-min build. 2023-06-03 14:22:16 -05:00
Calvin Rose
7d48b75f81 Update README.md 2023-06-03 14:19:02 -05:00
Calvin Rose
5f56bf836c Update meson.build file. 2023-06-03 13:55:49 -05:00
Ico Doornekamp
c0f5f97ddb Added misc tests to increase test coverage 2023-06-03 19:06:51 +02:00
Calvin Rose
15177ac2e9 Merge pull request #1162 from sogaiu/reorg-tests-new
Reorganize tests
2023-06-03 08:01:34 -05:00
Calvin Rose
8360bc93ac Merge pull request #1177 from zevv/zevv-isatty
added os/isatty, do not enable colors if stdout is not a tty
2023-06-03 07:58:16 -05:00
Ico Doornekamp
e0ea844d50 added os/isatty, do not enable colors if stdout is not a tty 2023-06-02 16:59:54 +02:00
sogaiu
9675411f35 Reorganize tests 2023-06-02 07:04:07 +09:00
Calvin Rose
e97299fc65 Fix #1174 - bad debug info causing stack traversal to segfault.
Coming from commit 77189b6e66, relating
to changes in source mapping debug info, this caused a segfault when
traversing a stack frame where the birth_pc was incredibly large due
to wrap around. This fix prevents the wrap around and does saturating
subtraction to 0.
2023-06-01 13:01:59 -05:00
Calvin Rose
26a113927e Add handling for new bytecode optimizations. 2023-06-01 12:47:59 -05:00
Calvin Rose
d0aa7ef590 Add a few asserts to quiet some of the -fanalyze calls in gcc 13. 2023-06-01 10:52:34 -05:00
Calvin Rose
5de889419f Rename contains? and contains-key? to has-value? and has-key?
Shorten docstrings to be less like a tutorial. They get put into RAM
and memory ain't free.
2023-05-31 22:35:57 -05:00
Calvin Rose
0fcbda2da7 Merge pull request #1017 from Techcable/feature/helper-func-contains
Add `contains?` helper function to boot.janet
2023-05-31 22:28:41 -05:00
Calvin Rose
14e33c295f Make clock tests less fragile for CI. 2023-05-31 22:21:12 -05:00
Calvin Rose
644ac8caf8 Add compiler optimizations for #1163 - eachp
Should result in much better bytecode in the simple case.
2023-05-31 12:26:27 -05:00
Calvin Rose
77189b6e66 Fix some symbol mapping inside nested functions. 2023-05-31 08:19:24 -05:00
Calvin Rose
4f8f7f66ee Merge branch 'bytecode_opt' 2023-05-31 07:57:13 -05:00
Calvin Rose
b099bd97f2 Merge branch 'master' into bytecode_opt 2023-05-30 18:13:02 -05:00
Calvin Rose
961c6ea15a Merge pull request #1172 from zevv/windows-recvfrom
fix for crash on windows in src/core/ev.c: initialze state->fromlen
2023-05-30 16:54:24 -05:00
Calvin Rose
9c97d8f648 Merge pull request #1171 from zevv/zevv-net-connect
Fixed net/connect binding address
2023-05-30 16:53:24 -05:00
Ico Doornekamp
ad7bf80611 fix for crash on windows in src/core/ev.c: initialze state->fromlen
before doing WSARecvFrom() to prevent crash (likely caused by the
memcpy() of `state->from` at line
2301 with the memcpy length set to -1)
2023-05-30 19:33:34 +02:00
Ico Doornekamp
40080b23ae Fixed net/connect binding address 2023-05-30 16:57:17 +02:00
Calvin Rose
7acb5c63e0 Remove bad windows10 check. 2023-05-29 18:17:22 -05:00
Calvin Rose
fcca9bbab3 Add recursion to the pruning optimization. 2023-05-29 18:05:14 -05:00
Calvin Rose
dbb2187425 Merge pull request #1167 from zevv/janet-formatbf-fix
Fix janet_formatbv() type when handling %d %u int specifiers
2023-05-29 18:03:13 -05:00
Calvin Rose
82e51f9e81 Merge pull request #1169 from zevv/fix-buffer-push-at-doc
Updated documentation for buffer/push-at
2023-05-29 18:02:05 -05:00
Calvin Rose
4782a76bca Add inital bytecode optimizations for #1163
This removes unnecessary movn, movf, lds, and a few other instructions.
Any instructions that has not side effects and writes to a slot that
isn't used can be removed. A number of other optimizations can follow
from this:

- Implement the def-aliasing-var optimization better
- This function can be iterated as a fix point until no more
  instructions are removed.
- If we implement slot renaming, then we no longer need to free slots
  and can simplify the initial code generation a lot.
2023-05-29 16:10:48 -05:00
Ico Doornekamp
d13788a4ed Updated documentation for buffer/push-at 2023-05-29 22:03:37 +02:00
Ico Doornekamp
e64a0175b1 change janet_formatbv() to handle int/unsigned int instead of long/unsigned long on '%d' and '%u' format specifiers. 2023-05-29 19:50:14 +02:00
Calvin Rose
4aca94154f Be more selective when testing FFI.
In the future, we really should get more FFI testing for
partially supported FFI on various platforms.
2023-05-28 15:28:17 -05:00
Calvin Rose
ac5f118dac Merge pull request #1164 from dressupgeekout/janet_h_symlink
More portable method of installing janet.h -> janet/janet.h symlink
2023-05-28 15:22:12 -05:00
Charlotte Koch
a2812ec5eb More portable method of installing janet.h -> janet/janet.h symlink 2023-05-27 14:22:11 -07:00
Calvin Rose
70f13f1b62 Merge pull request #1157 from zevv/file-lines
Add file/lines iterator
2023-05-26 18:16:14 -05:00
Calvin Rose
77e62a25cb Merge pull request #1160 from primo-ppcg/mapcat-et-al
Allow mapcat et al to accept multiple iterable arguments
2023-05-26 18:15:09 -05:00
Ico Doornekamp
09345ec786 file/linex now only acceps a file, not a path name 2023-05-26 17:50:26 +02:00
primo-ppcg
bad73baf98 Add test cases for variadic arguments to map-like functions 2023-05-26 19:08:00 +07:00
primo-ppcg
3602f5aa5d Update boot.janet
`kvs` is not yet defined at this point.
2023-05-25 18:27:31 +07:00
primo-ppcg
672b705faf Allow mapcat et al to accept multiple iterable arguments
#1159
2023-05-25 18:12:38 +07:00
Ico Doornekamp
64e3cdeb2b Add file/lines iterator 2023-05-24 16:54:04 +02:00
Calvin Rose
909c906080 Fix yields inside nested fibers. 2023-05-23 20:09:46 -05:00
Calvin Rose
71bde11e95 Allow one argument to while. 2023-05-23 20:09:46 -05:00
Calvin Rose
fc20fbed92 Merge pull request #1151 from zevv/document-string-format
Add docstring to string/format
2023-05-23 18:57:55 -05:00
Calvin Rose
e6b7c85c37 Merge pull request #1152 from zevv/error-messages
Improved various error messages when handling unexpected types.
2023-05-23 18:57:20 -05:00
Ico Doornekamp
b3a92363f8 Add docstring to string/format 2023-05-23 07:21:26 +02:00
Ico Doornekamp
e9f2d1aca7 changed some error messages 'x|y' -> 'x or y' 2023-05-23 06:58:52 +02:00
Ico Doornekamp
b4e3dbf331 Improved various error messages when handling unexpected types.
error: bad slot #1, expected string|symbol|keyword|buffer, got ...
error: bad slot #1, expected a string, symbol, keyword or buffer, got ...

bad s64 initializer: "donkey"
can not convert string "donkey" to s64
2023-05-23 06:57:12 +02:00
Calvin Rose
c3620786cf Merge branch 'master' of github.com:janet-lang/janet 2023-05-22 20:41:05 -05:00
Calvin Rose
41943746e4 Fix #1149 - deep-not= should only return true/false.
Also improve perf at same time.
2023-05-22 20:40:30 -05:00
Calvin Rose
176e816b8c Merge pull request #1153 from zevv/fix-warning
Fix warning in janet_gettime()
2023-05-22 18:46:55 -05:00
Ico Doornekamp
50a19bd870 Fix warning in janet_gettime() 2023-05-22 20:53:03 +02:00
Calvin Rose
57b751b994 Merge branch 'master' of github.com:janet-lang/janet 2023-05-21 16:23:44 -05:00
Calvin Rose
77732a8f44 inet_test change. 2023-05-21 13:36:11 -05:00
Calvin Rose
c47c2e538d Merge pull request #1137 from tionis/master
os/proc-kill now accepts an optional signal to send
2023-05-21 13:33:24 -05:00
Calvin Rose
cc5545277d Merge pull request #1147 from zevv/error-messages
improved error messages for special forms
2023-05-21 13:31:06 -05:00
Ico Doornekamp
63353b98cd improved error messages for special forms 2023-05-21 20:18:32 +02:00
tionis
4dfc869b8a fixed formatting in src/core/os.c 2023-05-21 15:55:11 +02:00
tionis
b4b1c7d80b Merge branch 'janet-lang:master' into master 2023-05-21 13:51:24 +00:00
tionis
e53c03028f ignoring signals on windows in os/proc-kill again 2023-05-21 15:50:15 +02:00
Calvin Rose
8680aef42f Merge pull request #1146 from zevv/os-clock
Add  clock sources to os/clock (:realtime, :monotonic, :cputime)
2023-05-21 08:35:24 -05:00
Calvin Rose
c3fd71d643 Merge pull request #1142 from tionis/thaw
added thaw to complement freeze
2023-05-21 08:09:47 -05:00
Ico Doornekamp
30c47d685d Fixed :cputime because msdn does not implement clock() properly 2023-05-21 07:29:27 +02:00
Ico Doornekamp
80db682109 Added tests for os/clock 2023-05-21 07:29:27 +02:00
Ico Doornekamp
e8e5f66f4c Implement janet_gettime() for win32 and macos; need testing 2023-05-21 07:29:27 +02:00
Ico Doornekamp
aaf3d08bcd Added 'source' argument to os/clock to select the clock source 2023-05-21 07:29:27 +02:00
Ico Doornekamp
61132d6c40 os/time and janet_gettime now use CLOCK_MONOTONIC instead of CLOCK_REALTIM, this matches the description from the documentation of os/clock. Fixes issue #1144 2023-05-21 07:29:27 +02:00
tionis
9cc0645a1e added test for thaw and freeze 2023-05-20 17:35:25 +02:00
Calvin Rose
fc8c6a429e Modulo should not be variadic. 2023-05-20 07:45:18 -05:00
Calvin Rose
2f966883d9 Fix #1145 - variadic imperative arith. macros.
Also update CHANGELOG
2023-05-20 07:42:50 -05:00
tionis
320ba80ca1 added support for tables/structs with prototypes in thaw 2023-05-20 14:00:33 +02:00
Calvin Rose
b621d4dd2e Merge pull request #1139 from zevv/async-connect
changed net/connect to be non-blocking / asynchronous
2023-05-19 21:12:16 -05:00
tionis
56d927c72d added thaw to complement freeze 2023-05-19 21:18:54 +02:00
tionis
53afc2e50a Merge branch 'janet-lang:master' into master 2023-05-19 19:14:12 +00:00
Ico Doornekamp
89debac8f6 Fixed janet_loop1_impl stream use after dealloc 2023-05-19 20:00:59 +02:00
Calvin Rose
f2197fa2d8 Merge pull request #1141 from zevv/mingw-test
Add CI test for mingw/wine on linux
2023-05-19 07:25:47 -05:00
Ico Doornekamp
a6a097c111 Add CI test for mingw/wine on linux 2023-05-18 15:15:41 +02:00
Ico Doornekamp
c3e28bc924 added deferred closing of streams after async connect() fails 2023-05-18 14:10:22 +02:00
Ico Doornekamp
8d78fb1f6b changed net/connect to be non-blocking / asynchronous 2023-05-18 10:55:48 +02:00
Calvin Rose
148917d4ca Move -g to CFLAGS to make it easier to remove/customize 2023-05-16 21:10:18 -05:00
Calvin Rose
d8cf9bf942 Merge pull request #1140 from zevv/debug-symbols
Enable debug symbols in janet binary; strip target at 'make install'
2023-05-16 21:08:12 -05:00
Calvin Rose
d6f5a060ed Squashed commit of the following:
commit 725b8749464895e21c761f1c5479692335282f62
Author: Calvin Rose <calsrose@gmail.com>
Date:   Tue May 16 20:58:34 2023 -0500

    Update header file.

commit 38bf2a5131
Author: Calvin Rose <calsrose@gmail.com>
Date:   Tue May 16 19:43:22 2023 -0500

    Run experiment on bsd.
2023-05-16 21:00:31 -05:00
Calvin Rose
692b6ef8ac Merge pull request #1138 from zevv/setsockopt
add net/setsockopt
2023-05-16 19:29:25 -05:00
Ico Doornekamp
ac5f1fe1be enable debug symbols in janet binary; strip target at 'make instal' 2023-05-16 19:48:18 +02:00
tionis
0f35acade1 use SIGTERM for os/proc-kill signal test 2023-05-16 18:47:38 +02:00
tionis
56d72ec4c5 support sending signals to processes on windows 2023-05-16 17:07:51 +02:00
tionis
71d51c160d added simple test for signal handling in os/proc-kill using :kill 2023-05-16 13:27:52 +02:00
tionis
0b58e505ee os/proc-kill now accepts an optional signal to send 2023-05-16 00:44:19 +02:00
Ico Doornekamp
2a6c615bec features.h: define _DARWIN_C_SOURCE for __APPLE__ 2023-05-15 16:55:09 +02:00
Ico Doornekamp
ab8c5a0b5f net/setsockopt optname symbols are now lower case 2023-05-15 15:25:09 +02:00
Ico Doornekamp
68c35feaea Formatting 2023-05-15 12:33:37 +02:00
Ico Doornekamp
88d0c2ca0f add net/setsockopt 2023-05-15 12:15:36 +02:00
Calvin Rose
398833ebe3 Enable FFI module unconditionally. 2023-05-14 09:18:54 -05:00
Calvin Rose
358f5a03bf Version bump to 1.28.0 2023-05-13 09:59:55 -05:00
Calvin Rose
fba1fdabe4 Update short-fn to fix #1123
Symbols are renamed on expansion to avoid the issue.
2023-05-13 09:44:30 -05:00
Calvin Rose
d42afd21e5 Merge branch 'master' of github.com:janet-lang/janet 2023-05-12 19:08:35 -05:00
Calvin Rose
20ada86761 Fix NAN typo. 2023-05-12 19:08:26 -05:00
Calvin Rose
3b353f1855 Merge pull request #1133 from zevv/cross
Updated Makefile for better cross-compilation support.
2023-05-12 08:41:54 -05:00
Calvin Rose
1467ab4f93 Copy paste error. 2023-05-11 20:56:12 -05:00
Calvin Rose
7e65c2bdad Fix #1130 - mod flipped for signed integers. 2023-05-11 18:15:37 -05:00
Calvin Rose
84a4e3e98a Update CHANGELOG.
and format.
2023-05-11 18:03:38 -05:00
Calvin Rose
bcbeedb001 Merge pull request #1128 from zevv/master
Added os.strftime()
2023-05-11 18:01:39 -05:00
Calvin Rose
e04b103b5d Merge pull request #1134 from CosmicToast/const_sourceline
Make JANET_FN_S* sourceline const
2023-05-11 17:59:27 -05:00
Chloe Kudryavtsev
ac75b94679 Make JANET_FN_S* sourceline const
Otherwise attempts to use it on some platforms cause the following error
`error: initializer element is not a compile-time constant`
when attempting to use the corresponding `JANET_REG`.
2023-05-11 16:07:34 -04:00
Ico Doornekamp
d3bb06cfd6 Updated Makefile for better cross-compilation support.
Building janet requires janet_boot to be run on the host at build time;

- $(UNAME) can now be overridden from the make cmdline
- Added $(RUN) variable to allow a emulator to be specified
- Added ".exe" extension to binaries when using MINGW

Examples:

Cross compiling for win32 and running under wine:

```
make test \
       CC=i686-w64-mingw32-gcc \
       LD=i686-w64-mingw32-gcc \
       UNAME=MINGW \
       RUN=wine

Janet 1.27.0-ad7c3bed mingw/x86/gcc - '(doc)' for help
```

Cross compiling for aarch64 and running under qemu:

```
make repl \
        CC=aarch64-none-linux-gnu-gcc \
        LD=aarch64-none-linux-gnu-gcc \
        RUN="qemu-aarch64 -L /tmp/aarch64/"

Janet 1.27.0-ad7c3bed linux/aarch64/gcc - '(doc)' for help
```
2023-05-11 07:46:36 +02:00
Ico Doornekamp
5cd729c4c1 Added os.strftime() 2023-05-11 06:08:19 +02:00
Calvin Rose
c9fd2bdf39 Merge branch 'master' of github.com:janet-lang/janet 2023-05-10 18:46:42 -05:00
Calvin Rose
e4be5992b3 Address issue with #1131 2023-05-10 18:43:33 -05:00
Calvin Rose
2ac4988f1b Merge pull request #1124 from sogaiu/tweak-ev-select-docstring
Tweak ev/select docstring
2023-05-08 04:17:25 -05:00
Calvin Rose
19f14adb9e Update changelog. 2023-05-07 21:07:22 -05:00
Calvin Rose
86de039492 Merge branch 'master' of github.com:janet-lang/janet 2023-05-07 11:54:20 -05:00
Calvin Rose
2360164e4f Address #1125 - fix ev/select to only take and release locks once.
By take and releasing locks twice per channel in the case where nothing
is reading, there was an opportunity for ev/select to hang in the
multithreaded case. Also silence valgrind/helgrind errors.
2023-05-07 11:54:06 -05:00
Calvin Rose
c93ddceadb Merge pull request #1122 from CosmicToast/getcbytes
Add get/opt cbytes
2023-05-07 10:33:09 -05:00
sogaiu
cd19dec44a Tweak ev/select docstring 2023-05-07 22:22:33 +09:00
Chloe Kudryavtsev
53ba9c800a Add get/opt cbytes
Like getcstring, but operates on a byteview.
When writing bindings (i.e what capi.c is primarily used for), it's
common to want to accept a buffer *or* a string rather than just
a string.
For this, a byteview is perfect (and why not accept keywords while
you're at it?).
However, there's no built-in function for getting a cstring out of
a byteview, this adds one.
This also reformulates getcstring to be an edge-case of getcbytes
(simply adding an explicit check for stringness).
2023-05-06 22:13:53 -04:00
Calvin Rose
cabbaded68 Add support for the NO_COLOR environment variable. 2023-05-06 16:33:45 -05:00
Calvin Rose
9bb589f827 update readme 2023-05-06 15:56:27 -05:00
Calvin Rose
c3a06686c2 Merge branch 'shell-win-feature-check' 2023-05-06 15:53:02 -05:00
Calvin Rose
7d57f87007 Address #1121 - disallow extra splices.
This turns splices that are ignored into compiler errors. Other
alternatives here should also be considered, for example making this
a compiler warning rather than an error. For example, the latest
spork as of a3ee63c137ee3234987dbbca71b566994ff8ae8c has an error of this
kind, but the resulting program does work correctly.

Also disallow splice propagation - code of the
form (+ 1 (do ;[2 3 4]) 5).
2023-05-06 13:12:31 -05:00
Calvin Rose
4cc4a9d38b (and ... <truthy-value> true) will return true as per docs. 2023-05-06 10:16:05 -05:00
Calvin Rose
02c7cd0194 Merge pull request #1116 from sogaiu/tweak-long-string-peg
Tweak long-string|bytes peg in test suite files
2023-04-30 16:21:12 -05:00
Calvin Rose
696efcb9e2 Add header file. 2023-04-30 12:19:55 -05:00
Calvin Rose
6e9cde8ac1 Add feature check for windows version shell.c
Tried to get console working on windows 7 and below
2023-04-30 10:36:42 -05:00
sogaiu
a9fae49671 Tweak long-string|bytes peg in test suite files 2023-04-30 21:55:43 +09:00
Calvin Rose
440af9fd64 Remove extra allocation in drop. 2023-04-24 09:41:33 -05:00
Calvin Rose
347721ae40 Fix macos behavior - Closes #1097, Fixes #1015 2023-04-24 09:37:49 -05:00
Calvin Rose
daea91044c Give different names to the user9 and user8 fiber statuses.
These now have semantic menaings that are pretty difficult to
work around. Code that tries to maniuplate user8 and user9 signals
right now may be affected
2023-04-24 09:19:15 -05:00
Calvin Rose
4ed3f2c662 Merge pull request #1114 from ianthehenry/drop-from-end
drop with a negative count now drops from the end
2023-04-24 09:16:10 -05:00
Calvin Rose
3641c8f60a Merge pull request #1108 from wackbyte/read
README grammar and formatting changes
2023-04-24 09:15:07 -05:00
Calvin Rose
e4b68cd940 Merge pull request #1109 from wackbyte/remove-double-space
Remove double space in help message
2023-04-24 09:11:45 -05:00
Calvin Rose
b8c936e2fe Merge pull request #1113 from ianthehenry/catseq
add catseq
2023-04-24 09:07:38 -05:00
Calvin Rose
83cd519702 Merge pull request #1112 from ianthehenry/dynamic-replace
string and peg replacement functions can now take functions
2023-04-24 09:07:03 -05:00
Ian Henry
54b54f85f3 drop with a negative count now drops from the end 2023-04-23 21:39:14 -07:00
Ian Henry
ccd874fe4e add catseq 2023-04-23 21:20:01 -07:00
Ian Henry
9dc7e8ed3a peg replacement functions have access to captures
When peg/replace or peg/replace-all are given a function to serve as the text
replacement, any captures produced by the PEG are passed as additional
arguments to that function.
2023-04-23 09:15:46 -07:00
Ian Henry
485099fd6e string and peg replacement functions can now take functions
Functions will be invoked with the matched text, and their result will be
coerced to a string and used as the new replacement text.

This also allows passing non-function, non-byteviewable values, which will be
converted into strings during replacement (only once, and only if at least
one match is found).
2023-04-23 08:36:17 -07:00
wackbyte
d359c6b43e Remove double space in help message 2023-04-22 21:46:24 -04:00
Calvin Rose
d9ed7a77f8 Merge pull request #1106 from CosmicToast/1105
handle null-byte case in scanformat (fixes #1105)
2023-04-22 15:25:48 -05:00
wackbyte
4238a4ca6a README grammar and formatting changes 2023-04-20 21:06:33 -04:00
Chloe Kudryavtsev
0902a5a981 improve null format handling
there was a request to improve the error message, but the whole function
has non-informative errors. (both functions, actually, since the code is
duplicated)
as such, instead of catching it directly, address the assumption that
led to the SIGSEGV and let it be caught by the functions themselves,
thus reusing existing error messages (which can then be improved
separately).
2023-04-20 11:51:11 -04:00
Chloe Kudryavtsev
f3192303ab check for NULL in get_fmt_mapping (fixes #1105)
When there is no format to be found after a %, get_fmt_mapping returns
NULL. It then gets called against strlen, which is a typical SEGV.
Check for NULL aginst mapping, which signals a null format being
specified.
2023-04-19 12:55:25 -04:00
Calvin Rose
bef5bd72c2 Merge pull request #1095 from ml-2/ml
Add `keep-syntax` and `keep-syntax!` functions
2023-04-08 10:46:47 -05:00
ML
b6175e4296 Add keep-syntax and keep-syntax! functions
These functions are designed to make it easier to properly preserve the
sourcemap and tuple type in macros. This commit also modifies the threading
macros to make use of these functions.
2023-04-07 21:09:52 -04:00
Calvin Rose
3858b2e177 Add ev/all-tasks to get running and pending root fibers. 2023-04-01 18:57:13 -05:00
Calvin Rose
9a76e77981 Update for undefined behavior sanitizer. 2023-03-24 18:49:21 -05:00
Calvin Rose
8182d640cd Merge branch 'master' of github.com:janet-lang/janet 2023-03-12 10:33:06 -05:00
Calvin Rose
1c6fda1a5c Address #1076 - unexpected shadowing behavior
While the old behavior was reasonable, it is not spelled out anywhere
in the documentation and was incidental rather than intentional.
Parameters of the same name of the function should probably take
precedence on name collision, following the principle of least surprise.
2023-03-12 10:30:59 -05:00
Calvin Rose
c51db1cf2f Merge pull request #1081 from ianthehenry/log-gamma-docstring
remove quotes in math/log-gamma docstring
2023-03-12 10:17:51 -05:00
Ian Henry
4e7930fc4c remove quotes around log-gamma 2023-03-11 12:26:45 -08:00
Calvin Rose
3563f8ccdb Merge pull request #1079 from dressupgeekout/charlotte_dragonfly
Some basic fixes for DragonFly
2023-03-08 15:05:51 -06:00
Charlotte Koch
575af763f6 os/which can return :dragonfly
While here, document that :bsd is another possible return value.
2023-03-07 06:45:31 -08:00
Charlotte Koch
8b16b9b246 Need to enable __BSD_VISIBLE on DragonFly in conjunction with -std=c99 2023-03-07 06:40:58 -08:00
Calvin Rose
01aab66667 Prepare for 1.27.0 release. 2023-03-05 09:48:25 -06:00
Calvin Rose
aa5c987a94 Change semantics of bracketed tuple equality.
Comparison between different bracket and normal tuples
will now take into account the delimiter type. This solves strange
non-locality issues in the compiler due to this false equality, and is
more consistent with Janet's otherwise strong equality philosophy.
2023-03-03 18:24:02 -06:00
Calvin Rose
75229332c8 Merge pull request #1075 from sogaiu/math-rng-int-docs
Tweak math/rng-int docs
2023-03-03 18:09:11 -06:00
sogaiu
9d5b1ba838 Tweak math/rng-int docs 2023-02-24 19:55:47 +09:00
Calvin Rose
f27b225b34 Merge pull request #1072 from sogaiu/ftell
Add file/tell
2023-02-21 07:13:00 -06:00
sogaiu
3c523d66e9 Add file/tell 2023-02-21 20:19:17 +09:00
Calvin Rose
1144c27c54 Merge pull request #1071 from ianthehenry/number-pegfault
fix a segfault in the (number) special
2023-02-20 21:01:33 -06:00
Ian Henry
b442b21d3f fix a segfault in the (number) special
This was an error about the base argument that referenced the tag argument,
which might not exist.
2023-02-20 17:07:42 -08:00
Calvin Rose
746ff5307d Update for more minimal builds. 2023-02-12 12:14:11 -06:00
Calvin Rose
ef85b24d8f Add optional offset to ffi/write. 2023-02-12 12:08:28 -06:00
Calvin Rose
c55d93512b Add buffer/push-at for easier manipulation of buffers
buffer/blit is difficult to use, and while buffer/push is the easiet
buffer manipulation function to use it only appends to the buffer.
buffer/push-at lets users manipulate buffers at any index - useful
for buffers used as an in-memory databases, for example.
2023-02-12 11:26:00 -06:00
Calvin Rose
2e38f9ba61 Allow passing pointer-buffers to other threads. 2023-02-12 11:07:45 -06:00
Calvin Rose
1cadff8e58 Add ffi/pointer-buffer for easier memory manipulation in FFI.
Added underlying buffer support for buffer instances that cannot
reallocated underlying memory - useful for (small) memory mapped
files and other FFI utilties.
2023-02-12 09:20:05 -06:00
Calvin Rose
d1eba60ba8 Add separate sandbox flag for file/temp
Doesn't really impart (much) file systtem information when used, and
can be used for a lot of things where file functions are used to process
in a stream.
2023-02-09 08:57:53 -06:00
Calvin Rose
057dccad8f Turn on nanboxing by default for risc-v 64. 2023-02-09 03:09:53 -06:00
Calvin Rose
4285200b4b Add a sandbox option to disable native modules.
Also sort the sandbox docstring list.
2023-02-09 00:19:56 -06:00
Calvin Rose
73c2fbbc2a Check sandbox capabilities instead of ignoring unknown ones. 2023-02-06 17:38:00 -06:00
Calvin Rose
37b7e170fa Update changelist. 2023-02-06 12:31:49 -06:00
Calvin Rose
b032d94877 Add sandboxing API.
The sandboxing API is meant to make janet a bit more attractive
for certain application embedding use cases. The sandboxing API
puts limits on what system resources the interpreter can access.
2023-02-06 09:05:57 -06:00
Calvin Rose
9476016741 Update asm.c 2023-02-05 23:49:18 -06:00
Calvin Rose
7a1c9c7798 Add support for debugging upvalues.
Upvalues are stored in the symbol slots structure as well, but
since they are always live, we repurpose the death_pc field to
refer to the environment index that we want to look at at runtime.
2023-02-05 15:30:01 -06:00
Calvin Rose
c7fb7b4451 Merge branch 'master' into localbindings 2023-02-05 11:36:57 -06:00
Calvin Rose
67c474fc7a More fixes to ev/gather (tested on httpf server). 2023-02-05 10:21:37 -06:00
Calvin Rose
4e8154cf8a Fix ev/gather to cancel children on cancellation.
Otherwise, we would be leaving zombie fibers around.
2023-02-05 09:43:16 -06:00
Calvin Rose
9582d3c623 Allow infinite wait to work without issues. 2023-02-05 09:29:39 -06:00
Calvin Rose
0079500713 Merge branch 'master' into localbindings 2023-02-04 13:39:24 -06:00
Calvin Rose
55af6ce834 Fix write after free with printing to files. 2023-02-04 13:36:30 -06:00
Calvin Rose
3e82fdc125 Update symbolmapping code with marshal/unmarshal. 2023-02-03 17:33:11 -06:00
Calvin Rose
7344a6cfc0 Fix null check. 2023-02-03 16:24:50 -06:00
Calvin Rose
0aded71343 Fix issue with environments in asm.c 2023-02-03 16:24:50 -06:00
Calvin Rose
7663b1e703 Fix null check. 2023-02-02 22:03:18 -06:00
Calvin Rose
282546c03f Fix issue with environments in asm.c 2023-02-02 21:12:17 -06:00
Calvin Rose
f4bc89d1c0 Progress. 2023-02-02 21:08:48 -06:00
Jona Ekenberg
fa277c3797 added future test for upvalues and symbolslots 2023-02-01 21:26:29 +01:00
Jona Ekenberg
c0c8ab25e6 added symbolslots to asm 2023-02-01 21:12:42 +01:00
Jona Ekenberg
b685bf3026 updated symbolslots-test 2023-02-01 11:46:36 +01:00
Jona Ekenberg
ce31db09e4 symbolslots should be gc'd, local_symbols always pushed in case *debug* is set in middle of function 2023-02-01 11:45:13 +01:00
Jona Ekenberg
624a6cf619 symbolslots nil when there are no symbols, changed debugger to not have special case 2023-02-01 11:25:52 +01:00
Jona Ekenberg
587aa87d28 symbolslots now use janet_v vectors, flat structure 2023-02-01 11:06:33 +01:00
Jona Ekenberg
88813c4f87 initial slotsyms implementation 2023-02-01 09:39:24 +01:00
Calvin Rose
dacbe29771 Allow round-tripping more functions with disasm and asm.
Nested functions that captured with environments didn't
work well with asm.
2023-01-30 09:04:42 -06:00
Calvin Rose
244833cfa1 Merge pull request #1040 from lgtm-migrator/codeql
Add CodeQL workflow for GitHub code scanning
2023-01-29 09:04:18 -06:00
Calvin Rose
05e7f974e3 Add os/compiler to the core.
Allows querying what compiler was used to compile Janet.
2023-01-28 14:00:02 -06:00
Calvin Rose
0dbef65a73 Merge pull request #1065 from sogaiu/comment-tweaks
Misc comment tweaks
2023-01-27 11:26:05 -06:00
Calvin Rose
9106228787 Add :riscv32 and :riscv32 values for os/arch. 2023-01-27 11:23:57 -06:00
Calvin Rose
6ae3bdb25c Add RISC-V 64 bit detection in janet.h 2023-01-26 22:40:05 -06:00
sogaiu
310bcec260 Misc comment tweaks 2023-01-25 18:45:19 +09:00
Calvin Rose
8c4cc4e671 Merge pull request #1064 from sogaiu/realpath-doc-tweak
Update os/realpath docstring
2023-01-24 09:50:44 -06:00
Calvin Rose
c6eaaa83ed Buffer initialized with janet_buffer_init will not be gced.
Set an internal flag that disables garbage collection on such
buffers. For all currently correct usage, this should have no effect,
and will fix use cases where buffers are initialized this way and then
passed to the interpreter.
2023-01-23 20:57:30 -06:00
sogaiu
8f598d6f96 Update os/realpath docstring 2023-01-23 12:55:04 +09:00
Calvin Rose
20bc323d17 Use gcc explicitly in mingw build. 2023-01-22 11:21:28 -06:00
Calvin Rose
8b0bcf4db9 Add the mingw toolchain. 2023-01-22 11:10:04 -06:00
Calvin Rose
8955e6f536 Merge branch 'master' of github.com:janet-lang/janet 2023-01-22 11:05:39 -06:00
Calvin Rose
f8ddea6452 Add msys2 testing with github actions. 2023-01-22 11:05:27 -06:00
Calvin Rose
987e04086d Merge pull request #1063 from AlecTroemel/1062-io-flag-types
use int32_t type for file flags, just like header
2023-01-22 10:56:19 -06:00
Calvin Rose
85f2acbf52 Fix tools/format.sh file permissions. 2023-01-22 10:47:33 -06:00
alectroemel
1acf4c3ab7 add int32_t type for file flags, just like header
Signed-off-by: alectroemel <alectroemel@hotmail.com>
Signed-off-by: alectroemel <alec@mirusresearch.com>
2023-01-22 10:24:46 -06:00
Calvin Rose
07a3158fba Merge pull request #1060 from ianthehenry/doc-typos
Fix some docstring typos
2023-01-21 16:21:57 -06:00
bakpakin
2f8bed9d82 Build and install an import library on mingw 2023-01-21 14:31:48 -06:00
bakpakin
a490937cd9 Add :mingw value when getting the OS setting when compiled with mingw. 2023-01-21 11:50:03 -06:00
bakpakin
8ee5942481 Fix windows build with JANET_NO_NET - #1055 2023-01-21 10:56:20 -06:00
bakpakin
93b469885a Initial Mingw support with Makefile.
Also add a macro JANET_MSVC to distinguish between
a windows build (JANET_WINDOWS) and a build with msvc.
2023-01-21 10:37:34 -06:00
Calvin Rose
d8d1de2dcb Don't compile library loading code on windows if it is disabled. 2023-01-21 09:36:03 -06:00
Ian Henry
ab224514f0 Fix some docstring typos. 2023-01-18 19:41:56 -08:00
Calvin Rose
75179de8da Merge pull request #1056 from fd00/use-dev-urandom-on-cygwin
Use `/dev/urandom` for `janet_cryptorand` on cygwin
2023-01-08 09:29:52 -06:00
Calvin Rose
c28df14e6b Prepare for 1.26.0 release 2023-01-07 15:08:40 -06:00
Calvin Rose
b73855b193 Merge branch 'master' of github.com:janet-lang/janet 2023-01-07 15:05:16 -06:00
Calvin Rose
2093ab2baa Update copyrights. 2023-01-07 15:04:56 -06:00
Calvin Rose
a0f40042cb Update copyright year. 2023-01-07 15:03:35 -06:00
Daisuke Fujimura (fd0)
3254c2c477 Use /dev/urandom for janet_cryptorand on cygwin 2023-01-07 08:58:35 +09:00
Calvin Rose
0a8eb9e3ba Merge pull request #1057 from sogaiu/update-tests-for-meson
Add test files to meson suite 11 - 14
2023-01-04 04:13:18 -06:00
sogaiu
70e0c6f9ef Add test files to meson suite 11 - 14 2023-01-04 12:59:26 +09:00
Calvin Rose
a8a78d4525 Merge pull request #1052 from dressupgeekout/cpu_count_reduced_os
(os/cpu-count) should not be defined at all with JANET_REDUCED_OS
2022-12-16 11:11:30 -06:00
Calvin Rose
57e6ee963d Merge pull request #1046 from dressupgeekout/charlotte_sort_doc
Explicitly mention that `sort-by` sorts a list in place.
2022-12-16 11:11:07 -06:00
Calvin Rose
ce6bfb8420 Merge pull request #1049 from harryvederci/patch-1
Improve documentation for the `all` function.
2022-12-16 09:51:59 -06:00
Calvin Rose
f0672bdc59 Merge pull request #1051 from sogaiu/math-abs-vs-fabs-issue
Tweak math/abs to improve doc result
2022-12-16 09:51:43 -06:00
Charlotte Koch
23de953fbd (os/cpu-count) should not be defined at all with JANET_REDUCED_OS 2022-12-15 20:16:43 -08:00
Calvin Rose
03c496bdd8 Update changelog 2022-12-15 21:38:36 -06:00
Calvin Rose
d5ee6cf521 Add malloc and free to ffi.
Very "unsafe", but a good tool of last resort. In most cases
a buffer is preferable, but the lifetime can be a bit unclear.
This allows very granular control over memory.
2022-12-15 21:35:44 -06:00
sogaiu
fb7981e053 Tweak math/abs to improve doc result 2022-12-11 00:09:50 +09:00
harryvederci
846123ecab Improve documentation for the all function. 2022-12-09 11:16:42 +00:00
Calvin Rose
373cb444fe Merge branch 'master' of github.com:janet-lang/janet 2022-12-04 11:08:28 -06:00
Calvin Rose
90f212df92 Add length method ffi/jitfn abstract values. 2022-12-04 11:08:17 -06:00
Calvin Rose
12286e4246 Add length method ffi/jitfn abstract values. 2022-12-04 10:27:28 -06:00
Calvin Rose
aa60c1f36a Add ffi jit example. 2022-12-03 17:52:23 -06:00
Calvin Rose
c731f01067 Address windows compilation warning. 2022-12-03 12:10:22 -06:00
Calvin Rose
6c9c1cdb30 MAP_ANON(YMOUS) not strictly needed. 2022-12-03 11:45:33 -06:00
Calvin Rose
9ba2b40e87 Add MAP_ANON instead of MAP_ANONYMOUS for mac 2022-12-03 11:31:04 -06:00
Calvin Rose
7a3d055012 Add ffi/jitfn for JIT compilation.
Convert a byte sequence of machine code to an
an executable pointer that can be used with ffi/call.
2022-12-03 11:26:23 -06:00
Calvin Rose
0824f45e29 Format compile.c 2022-11-27 10:15:01 -06:00
Charlotte Koch
4debe3446c Explicitly mention that sort-by sorts a list in place. 2022-11-20 20:51:49 -08:00
Calvin Rose
07fe9bcdf6 Update state header to include pthread 2022-11-11 11:48:50 -06:00
Calvin Rose
6a557a73f5 Simplify eval.
Also add more conventional handling of nil to the `compile` function.
2022-11-11 11:25:06 -06:00
Calvin Rose
8d1cfe0c56 Simplify eval-string implementation. 2022-11-11 11:15:53 -06:00
Calvin Rose
a3a42eebea Create pthread threads with detached attribute.
Rather than calling pthread_detach on a default thread.
2022-11-11 11:01:59 -06:00
Calvin Rose
76be8006a4 Add channel marshalling. 2022-11-10 16:32:54 -06:00
Calvin Rose
bfcfd58259 Update for TCC to include stdatomic.h 2022-11-09 07:55:21 -06:00
Calvin Rose
914a4360e7 Indicate version bump since header file changed. 2022-11-05 16:38:52 -05:00
Calvin Rose
8c31874eeb Remove unused assert.h 2022-11-05 11:44:14 -05:00
Calvin Rose
ef7afeb2ea Add 64 bit integer support to printf and other formatting functions. 2022-11-05 11:33:19 -05:00
LGTM Migrator
4067f883a2 Add CodeQL workflow for GitHub code scanning 2022-11-05 10:22:49 +00:00
Calvin Rose
c8974fffbe Fix docstring. 2022-11-04 11:23:08 -05:00
Calvin Rose
b75fb8dc9e Add :@all: to module/expand-path
Allow more easily importing modules from custom directories
without jumping through too many hoops. Technically, this was
possible before but required circumventing the built-in module/paths
and was just a hassle.

Also add entries to module/path (and module/add-path) to allow code
like the following.

(setdyn :my-libs "/home/me/janet-stuff/")

(import @my-libs/toolbox)

Intended for things like test harnesses where code might not
be installed to the usual directories.
2022-11-04 11:15:48 -05:00
Calvin Rose
57356781a9 Fix typo. 2022-10-30 13:36:13 -05:00
Calvin Rose
e43eab5fd6 Fix panicf call. 2022-10-30 09:57:40 -05:00
Calvin Rose
894cd0e022 Prepare for 1.25.1 release. 2022-10-29 11:58:29 -05:00
Calvin Rose
db2c63fffc Update CHANGELOG.md 2022-10-24 20:32:02 -05:00
Calvin Rose
60e0f32f1a Fix os/open with :rw permissions on posix. 2022-10-24 19:39:58 -05:00
Calvin Rose
e731996a68 Allow overriding JANETCONF_HEADER in Makefile.
This allows a configuration workflow that is a bit simpler than before
and doesn't requiring applying patches. Instead, add a config.mk to
source dir with JANETCONF_HEADER=myconfig.h and compile as usual.

The patching workflow will of course still work exactly as before.
2022-10-24 09:49:51 -05:00
Calvin Rose
2f69cd4209 Add easier option for adding config.mk in root directory. 2022-10-23 13:11:07 -05:00
Calvin Rose
fd59de25c5 Add memcmp to the core. Useful in binary protocol implementations. 2022-10-18 11:54:07 -05:00
Calvin Rose
af12c3d41a Typo fixes. 2022-10-10 18:38:24 -05:00
Techcable
e78a3d1c19 Add unit tests for contains? 2022-08-26 21:47:18 -07:00
Techcable
c099ec05ee Remove documentation on type error from index-of
Three reasons:
1. This same behavior is not documented on the `next` function
2. This function does not throw the error directly,
   it only throws an error because `next` does.
3. Following the same idea as the previous commit, this behavior is
   more or less implementation-defined for nonsensical types
  > In dynamic languages, the usual idea is garbage in, garbage out.

Various other documentation cleanup.
2022-08-26 21:46:58 -07:00
Techcable
a20612478e Remove try from contains?, allowing type errors
> Remove the try. In dynamic languages, the usual idea is garbage in, garbage out. You misunderstood my point about the type error. “Test” functions are not special in that regard.
> - @bakpakin
2022-08-26 20:36:17 -07:00
Techcable
f778e8bbd1 Fix incorrect usage of the test macro
I need unit tests....
2022-08-26 15:35:26 -07:00
Techcable
7203c046f9 Remove collection? type test
No longer used to guard the type tests.
2022-08-26 15:23:52 -07:00
Techcable
754b61c593 Clarify documentation of contains?
Also contains-value?
2022-08-26 15:19:39 -07:00
Techcable
927e9e4e4d Make contains? consistently iterate over values.
Remove `contains-value?` because it is now redundant.

Clarify in the documentation that it checks dictionary values.
2022-08-26 15:06:09 -07:00
Techcable
699f9622d7 Warn about index-of type errors when not iterable
This is just documentation of existing behavior, it does not change anything.

The reason index-of throws a type error on non-iterable types is because `next` does.
This is hardcoded into the JOP_NEXT opcode (see src/core/value.c:janet_next_impl).

Unfortunately, there is currently no corresponding `iterable?` check.
2022-08-26 15:05:39 -07:00
Techcable
765eb84c33 on bad type, contains? shuld return false (not error)
Note this actually changes behavior from a thin wrapper over `index-of`.
This is because `(index-of 3 3)` throws "error: expected iterable type, got 3"
2022-08-26 14:23:36 -07:00
Techcable
12a1849090 Add utilities for contains? and contains-key?
This is significantly clearer than using (not (nil? (index-of col val)))

Most major programming languages offer some sort of contains function (Python, Java, C, Rust).
The only exception I know of is C.
2022-08-25 21:00:02 -07:00
116 changed files with 7656 additions and 3778 deletions

41
.github/workflows/codeql.yml vendored Normal file
View File

@@ -0,0 +1,41 @@
name: "CodeQL"
on:
push:
branches: [ "master" ]
pull_request:
branches: [ "master" ]
schedule:
- cron: "2 7 * * 4"
jobs:
analyze:
name: Analyze
runs-on: ubuntu-latest
permissions:
actions: read
contents: read
security-events: write
strategy:
fail-fast: false
matrix:
language: [ cpp ]
steps:
- name: Checkout
uses: actions/checkout@v3
- name: Initialize CodeQL
uses: github/codeql-action/init@v2
with:
languages: ${{ matrix.language }}
queries: +security-and-quality
- name: Autobuild
uses: github/codeql-action/autobuild@v2
- name: Perform CodeQL Analysis
uses: github/codeql-action/analyze@v2
with:
category: "/language:${{ matrix.language }}"

View File

@@ -35,3 +35,57 @@ jobs:
- name: Test the project
shell: cmd
run: build_win test
test-mingw:
name: Build on Windows with Mingw (no test yet)
runs-on: windows-latest
defaults:
run:
shell: msys2 {0}
steps:
- name: Checkout the repository
uses: actions/checkout@master
- name: Setup Mingw
uses: msys2/setup-msys2@v2
with:
msystem: UCRT64
update: true
install: >-
base-devel
git
gcc
- name: Build the project
shell: cmd
run: make -j CC=gcc
test-mingw-linux:
name: Build and test with Mingw on Linux + Wine
runs-on: ubuntu-latest
steps:
- name: Checkout the repository
uses: actions/checkout@master
- name: Setup Mingw and wine
run: |
sudo dpkg --add-architecture i386
sudo apt-get update
sudo apt-get install libstdc++6:i386 libgcc-s1:i386
sudo apt-get install gcc-mingw-w64-x86-64-win32 wine wine32 wine64
- name: Compile the project
run: make clean && make CC=x86_64-w64-mingw32-gcc LD=x86_64-w64-mingw32-gcc UNAME=MINGW RUN=wine
- name: Test the project
run: make test UNAME=MINGW RUN=wine
test-arm-linux:
name: Build and test ARM32 cross compilation
runs-on: ubuntu-latest
steps:
- name: Checkout the repository
uses: actions/checkout@master
- name: Setup qemu and cross compiler
run: |
sudo apt-get update
sudo apt-get install gcc-arm-linux-gnueabi qemu-user
- name: Compile the project
run: make RUN="qemu-arm -L /usr/arm-linux-gnueabi/" CC=arm-linux-gnueabi-gcc LD=arm-linux-gnueabi-gcc
- name: Test the project
run: make RUN="qemu-arm -L /usr/arm-linux-gnueabi/" SUBRUN="qemu-arm -L /usr/arm-linux-gnueabi/" test

5
.gitignore vendored
View File

@@ -68,10 +68,13 @@ tags
vgcore.*
*.out.*
# Wix artifacts
# WiX artifacts
*.msi
*.wixpdb
# Makefile config
/config.mk
# Created by https://www.gitignore.io/api/c
### C ###

View File

@@ -1,12 +1,84 @@
# Changelog
All notable changes to this project will be documented in this file.
## 1.29.1 - 2023-06-19
- Add support for passing booleans to PEGs for "always" and "never" matching.
- Allow dictionary types for `take` and `drop`
- Fix bug with closing channels while other fibers were waiting on them - `ev/take`, `ev/give`, and `ev/select` will now return the correct (documented) value when another fiber closes the channel.
- Add `ffi/calling-conventions` to show all available calling conventions for FFI.
- Add `net/setsockopt`
- Add `signal` argument to `os/proc-kill` to send signals besides `SIGKILL` on Posix.
- Add `source` argument to `os/clock` to get different time sources.
- Various combinator functions now are variadic like `map`
- Add `file/lines` to iterate over lines in a file lazily.
- Reorganize test suite to be sorted by module rather than pseudo-randomly.
- Add `*task-id*`
- Add `env` argument to `fiber/new`.
- Add `JANET_NO_AMALG` flag to Makefile to properly incremental builds
- Optimize bytecode compiler to generate fewer instructions and improve loops.
- Fix bug with `ev/gather` and hung fibers.
- Add `os/isatty`
- Add `has-key?` and `has-value?`
- Make imperative arithmetic macros variadic
- `ev/connect` now yields to the event loop instead of blocking while waiting for an ACK.
## 1.28.0 - 2023-05-13
- Various bug fixes
- Make nested short-fn's behave a bit more predictably (it is still not recommended to nest short-fns).
- Add `os/strftime` for date formatting.
- Fix `ev/select` on threaded channels sometimes live-locking.
- Support the `NO_COLOR` environment variable to turn off VT100 color codes in repl (and in scripts).
See http://no-color.org/
- Disallow using `(splice x)` in contexts where it doesn't make sense rather than silently coercing to `x`.
Instead, raise a compiler error.
- Change the names of `:user8` and `:user9` sigals to `:interrupt` and `:await`
- Change the names of `:user8` and `:user9` fiber statuses to `:interrupted` and `:suspended`.
- Add `ev/all-tasks` to see all currently suspended fibers.
- Add `keep-syntax` and `keep-syntax!` functions to make writing macros easier.
## 1.27.0 - 2023-03-05
- Change semantics around bracket tuples to no longer be equal to regular tuples.
- Add `index` argument to `ffi/write` for symmetry with `ffi/read`.
- Add `buffer/push-at`
- Add `ffi/pointer-buffer` to convert pointers to buffers the cannot be reallocated. This
allows easier manipulation of FFI memory, memory mapped files, and buffer memory shared between threads.
- Calling `ev/cancel` on a fiber waiting on `ev/gather` will correctly
cancel the child fibers.
- Add `(sandbox ...)` function to core for permission based security. Also add `janet_sandbox` to C API.
The sandbox allows limiting access to the file system, network, ffi, and OS resources at runtime.
- Add `(.locals)` function to debugger to see currently bound local symbols.
- Track symbol -> slot mapping so debugger can get symbolic information. This exposes local bindings
in `debug/stack` and `disasm`.
- Add `os/compiler` to detect what host compiler was used to compile the interpreter
- Add support for mingw and cygwin builds (mingw support also added in jpm).
## 1.26.0 - 2023-01-07
- Add `ffi/malloc` and `ffi/free`. Useful as tools of last resort.
- Add `ffi/jitfn` to allow calling function pointers generated at runtime from machine code.
Bring your own assembler, though.
- Channels can now be marshalled. Pending state is not saved, only items in the channel.
- Use the new `.length` function pointer on abstract types for lengths. Adding
a `length` method will still work as well.
- Support byte views on abstract types with the `.bytes` function pointer.
- Add the `u` format specifier to printf family functions.
- Allow printing 64 integer types in `printf` and `string/format` family functions.
- Allow importing modules from custom directories more easily with the `@` prefix
to module paths. For example, if there is a dynamic binding :custom-modules that
is a file system path to a directory of modules, import from that directory with
`(import @custom-modules/mymod)`.
- Fix error message bug in FFI library.
## 1.25.1 - 2022-10-29
- Add `memcmp` function to core library.
- Fix bug in `os/open` with `:rw` permissions not correct on Linux.
- Support config.mk for more easily configuring the Makefile.
## 1.25.0 - 2022-10-10
- Windows FFI fixes.
- Fix PEG `if-not` combinator with captures in the condition
- Fix bug with `os/date` with nil first argument
- Fix bug with `net/accept` on Linux that could leak file descriptors to subprocesses
- Reduce number of hash collisiions from pointer hashing
- Reduce number of hash collisions from pointer hashing
- Add optional parameter to `marshal` to skip cycle checking code
## 1.24.1 - 2022-08-24

View File

@@ -1,4 +1,4 @@
Copyright (c) 2021 Calvin Rose and contributors
Copyright (c) 2023 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

View File

@@ -1,4 +1,4 @@
# Copyright (c) 2022 Calvin Rose
# Copyright (c) 2023 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,21 +21,26 @@
################################
##### Set global variables #####
################################
sinclude config.mk
PREFIX?=/usr/local
JANETCONF_HEADER?=src/conf/janetconf.h
INCLUDEDIR?=$(PREFIX)/include
BINDIR?=$(PREFIX)/bin
LIBDIR?=$(PREFIX)/lib
JANET_BUILD?="\"$(shell git log --pretty=format:'%h' -n 1 2> /dev/null || echo local)\""
CLIBS=-lm -lpthread
JANET_TARGET=build/janet
JANET_BOOT=build/janet_boot
JANET_IMPORT_LIB=build/janet.lib
JANET_LIBRARY=build/libjanet.so
JANET_STATIC_LIBRARY=build/libjanet.a
JANET_PATH?=$(LIBDIR)/janet
JANET_MANPATH?=$(PREFIX)/share/man/man1/
JANET_PKG_CONFIG_PATH?=$(LIBDIR)/pkgconfig
JANET_DIST_DIR?=janet-dist
JANET_BOOT_FLAGS:=. JANET_PATH '$(JANET_PATH)'
JANET_TARGET_OBJECTS=build/janet.o build/shell.o
JPM_TAG?=master
DEBUGGER=gdb
SONAME_SETTER=-Wl,-soname,
@@ -43,18 +48,25 @@ SONAME_SETTER=-Wl,-soname,
# For cross compilation
HOSTCC?=$(CC)
HOSTAR?=$(AR)
CFLAGS?=-O2
CFLAGS?=-O2 -g
LDFLAGS?=-rdynamic
RUN:=$(RUN)
COMMON_CFLAGS:=-std=c99 -Wall -Wextra -Isrc/include -Isrc/conf -fvisibility=hidden -fPIC
BOOT_CFLAGS:=-DJANET_BOOTSTRAP -DJANET_BUILD=$(JANET_BUILD) -O0 -g $(COMMON_CFLAGS)
BOOT_CFLAGS:=-DJANET_BOOTSTRAP -DJANET_BUILD=$(JANET_BUILD) -O0 $(COMMON_CFLAGS) -g
BUILD_CFLAGS:=$(CFLAGS) $(COMMON_CFLAGS)
# Disable amalgamated build
ifeq ($(JANET_NO_AMALG), 1)
JANET_TARGET_OBJECTS+=$(patsubst src/%.c,build/%.bin.o,$(JANET_CORE_SOURCES))
JANET_BOOT_FLAGS+=image-only
endif
# For installation
LDCONFIG:=ldconfig "$(LIBDIR)"
# Check OS
UNAME:=$(shell uname -s)
UNAME?=$(shell uname -s)
ifeq ($(UNAME), Darwin)
CLIBS:=$(CLIBS) -ldl
SONAME_SETTER:=-Wl,-install_name,
@@ -76,14 +88,22 @@ ifeq ($(shell uname -o), Android)
endif
endif
$(shell mkdir -p build/core build/c build/boot)
# Mingw
ifeq ($(findstring MINGW,$(UNAME)), MINGW)
CLIBS:=-lws2_32 -lpsapi -lwsock32
LDFLAGS:=-Wl,--out-implib,$(JANET_IMPORT_LIB)
JANET_TARGET:=$(JANET_TARGET).exe
JANET_BOOT:=$(JANET_BOOT).exe
endif
$(shell mkdir -p build/core build/c build/boot build/mainclient)
all: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.h
######################
##### Name Files #####
######################
JANET_HEADERS=src/include/janet.h src/conf/janetconf.h
JANET_HEADERS=src/include/janet.h $(JANETCONF_HEADER)
JANET_LOCAL_HEADERS=src/core/features.h \
src/core/util.h \
@@ -155,46 +175,53 @@ $(JANET_BOOT_OBJECTS): $(JANET_BOOT_HEADERS)
build/%.boot.o: src/%.c $(JANET_HEADERS) $(JANET_LOCAL_HEADERS) Makefile
$(CC) $(BOOT_CFLAGS) -o $@ -c $<
build/janet_boot: $(JANET_BOOT_OBJECTS)
$(JANET_BOOT): $(JANET_BOOT_OBJECTS)
$(CC) $(BOOT_CFLAGS) -o $@ $(JANET_BOOT_OBJECTS) $(CLIBS)
# Now the reason we bootstrap in the first place
build/c/janet.c: build/janet_boot src/boot/boot.janet
build/janet_boot . JANET_PATH '$(JANET_PATH)' > $@
build/c/janet.c: $(JANET_BOOT) src/boot/boot.janet
$(RUN) $(JANET_BOOT) $(JANET_BOOT_FLAGS) > $@
cksum $@
##################
##### Quicky #####
##################
build/%.bin.o: src/%.c $(JANET_HEADERS) $(JANET_LOCAL_HEADERS) Makefile
$(HOSTCC) $(BUILD_CFLAGS) -o $@ -c $<
########################
##### Amalgamation #####
########################
ifeq ($(UNAME), Darwin)
SONAME=libjanet.1.25.dylib
SONAME=libjanet.1.29.dylib
else
SONAME=libjanet.so.1.25
SONAME=libjanet.so.1.29
endif
build/c/shell.c: src/mainclient/shell.c
cp $< $@
build/janet.h: $(JANET_TARGET) src/include/janet.h src/conf/janetconf.h
./$(JANET_TARGET) tools/patch-header.janet src/include/janet.h src/conf/janetconf.h $@
build/janet.h: $(JANET_TARGET) src/include/janet.h $(JANETCONF_HEADER)
$(RUN) ./$(JANET_TARGET) tools/patch-header.janet src/include/janet.h $(JANETCONF_HEADER) $@
build/janetconf.h: src/conf/janetconf.h
build/janetconf.h: $(JANETCONF_HEADER)
cp $< $@
build/janet.o: build/c/janet.c src/conf/janetconf.h src/include/janet.h
build/janet.o: build/c/janet.c $(JANETCONF_HEADER) src/include/janet.h
$(HOSTCC) $(BUILD_CFLAGS) -c $< -o $@
build/shell.o: build/c/shell.c src/conf/janetconf.h src/include/janet.h
build/shell.o: build/c/shell.c $(JANETCONF_HEADER) src/include/janet.h
$(HOSTCC) $(BUILD_CFLAGS) -c $< -o $@
$(JANET_TARGET): build/janet.o build/shell.o
$(JANET_TARGET): $(JANET_TARGET_OBJECTS)
$(HOSTCC) $(LDFLAGS) $(BUILD_CFLAGS) -o $@ $^ $(CLIBS)
$(JANET_LIBRARY): build/janet.o build/shell.o
$(JANET_LIBRARY): $(JANET_TARGET_OBJECTS)
$(HOSTCC) $(LDFLAGS) $(BUILD_CFLAGS) $(SONAME_SETTER)$(SONAME) -shared -o $@ $^ $(CLIBS)
$(JANET_STATIC_LIBRARY): build/janet.o build/shell.o
$(JANET_STATIC_LIBRARY): $(JANET_TARGET_OBJECTS)
$(HOSTAR) rcs $@ $^
###################
@@ -206,19 +233,19 @@ $(JANET_STATIC_LIBRARY): build/janet.o build/shell.o
TEST_SCRIPTS=$(wildcard test/suite*.janet)
repl: $(JANET_TARGET)
./$(JANET_TARGET)
$(RUN) ./$(JANET_TARGET)
debug: $(JANET_TARGET)
$(DEBUGGER) ./$(JANET_TARGET)
VALGRIND_COMMAND=valgrind --leak-check=full
VALGRIND_COMMAND=valgrind --leak-check=full --quiet
valgrind: $(JANET_TARGET)
$(VALGRIND_COMMAND) ./$(JANET_TARGET)
test: $(JANET_TARGET) $(TEST_PROGRAMS)
for f in test/suite*.janet; do ./$(JANET_TARGET) "$$f" || exit; done
for f in examples/*.janet; do ./$(JANET_TARGET) -k "$$f"; done
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)
for f in test/suite*.janet; do $(VALGRIND_COMMAND) ./$(JANET_TARGET) "$$f" || exit; done
@@ -257,7 +284,7 @@ build/janet-%.tar.gz: $(JANET_TARGET) \
docs: build/doc.html
build/doc.html: $(JANET_TARGET) tools/gendoc.janet
$(JANET_TARGET) tools/gendoc.janet > build/doc.html
$(RUN) $(JANET_TARGET) tools/gendoc.janet > build/doc.html
########################
##### Installation #####
@@ -273,7 +300,7 @@ build/janet.pc: $(JANET_TARGET)
echo "Name: janet" >> $@
echo "Url: https://janet-lang.org" >> $@
echo "Description: Library for the Janet programming language." >> $@
$(JANET_TARGET) -e '(print "Version: " janet/version)' >> $@
$(RUN) $(JANET_TARGET) -e '(print "Version: " janet/version)' >> $@
echo 'Cflags: -I$${includedir}' >> $@
echo 'Libs: -L$${libdir} -ljanet' >> $@
echo 'Libs.private: $(CLIBS)' >> $@
@@ -281,9 +308,10 @@ build/janet.pc: $(JANET_TARGET)
install: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.pc build/janet.h
mkdir -p '$(DESTDIR)$(BINDIR)'
cp $(JANET_TARGET) '$(DESTDIR)$(BINDIR)/janet'
strip '$(DESTDIR)$(BINDIR)/janet'
mkdir -p '$(DESTDIR)$(INCLUDEDIR)/janet'
cp -r build/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet'
ln -sf -T ./janet/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet.h' || true #fixme bsd
ln -sf ./janet/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet.h'
mkdir -p '$(DESTDIR)$(JANET_PATH)'
mkdir -p '$(DESTDIR)$(LIBDIR)'
if test $(UNAME) = Darwin ; then \
@@ -300,6 +328,7 @@ install: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.pc
cp janet.1 '$(DESTDIR)$(JANET_MANPATH)'
mkdir -p '$(DESTDIR)$(JANET_PKG_CONFIG_PATH)'
cp build/janet.pc '$(DESTDIR)$(JANET_PKG_CONFIG_PATH)/janet.pc'
cp '$(JANET_IMPORT_LIB)' '$(DESTDIR)$(LIBDIR)' || echo 'no import lib to install (mingw only)'
[ -z '$(DESTDIR)' ] && $(LDCONFIG) || echo "You can ignore this error for non-Linux systems or local installs"
install-jpm-git: $(JANET_TARGET)
@@ -312,7 +341,7 @@ install-jpm-git: $(JANET_TARGET)
JANET_HEADERPATH='$(INCLUDEDIR)/janet' \
JANET_BINPATH='$(BINDIR)' \
JANET_LIBPATH='$(LIBDIR)' \
../../$(JANET_TARGET) ./bootstrap.janet
$(RUN) ../../$(JANET_TARGET) ./bootstrap.janet
uninstall:
-rm '$(DESTDIR)$(BINDIR)/janet'
@@ -332,7 +361,7 @@ format:
grammar: build/janet.tmLanguage
build/janet.tmLanguage: tools/tm_lang_gen.janet $(JANET_TARGET)
$(JANET_TARGET) $< > $@
$(RUN) $(JANET_TARGET) $< > $@
compile-commands:
# Requires pip install copmiledb

230
README.md
View File

@@ -6,58 +6,131 @@
<img src="https://raw.githubusercontent.com/janet-lang/janet/master/assets/janet-w200.png" alt="Janet logo" width=200 align="left">
**Janet** is a functional and imperative programming language and bytecode interpreter. It is a
lisp-like language, but lists are replaced
by other data structures (arrays, tables (hash table), struct (immutable hash table), tuples).
The language also supports bridging to native code written in C, meta-programming with macros, and bytecode assembly.
**Janet** is a programming language for system scripting, expressive automation, and
extending programs written in C or C++ with user scripting capabilities.
Janet makes a good system scripting language, or a language to embed in other programs.
It's like Lua and GNU Guile in that regard. It has more built-in functionality and a richer core language than
Lua, but smaller than GNU Guile or Python. However, it is much easier to embed and port than Python or Guile.
There is a REPL for trying out the language, as well as the ability
to run script files. This client program is separate from the core runtime, so
Janet can be embedded in other programs. Try Janet in your browser at
[https://janet-lang.org](https://janet-lang.org).
<https://janet-lang.org>.
If you'd like to financially support the ongoing development of Janet, consider
[sponsoring its primary author](https://github.com/sponsors/bakpakin) through GitHub.
<br>
## Use Cases
## Examples
Janet makes a good system scripting language, or a language to embed in other programs.
It's like Lua and Guile in that regard. It has more built-in functionality and a richer core language than
Lua, but smaller than GNU Guile or Python.
See the examples directory for all provided example programs.
## Features
### Game of Life
* Configurable at build time - turn features on or off for a smaller or more featureful build
* Minimal setup - one binary and you are good to go!
```janet
# John Conway's Game of Life
(def- window
(seq [x :range [-1 2]
y :range [-1 2]
:when (not (and (zero? x) (zero? y)))]
[x y]))
(defn- neighbors
[[x y]]
(map (fn [[x1 y1]] [(+ x x1) (+ y y1)]) window))
(defn tick
"Get the next state in the Game Of Life."
[state]
(def cell-set (frequencies state))
(def neighbor-set (frequencies (mapcat neighbors state)))
(seq [coord :keys neighbor-set
:let [count (get neighbor-set coord)]
:when (or (= count 3) (and (get cell-set coord) (= count 2)))]
coord))
(defn draw
"Draw cells in the game of life from (x1, y1) to (x2, y2)"
[state x1 y1 x2 y2]
(def cellset @{})
(each cell state (put cellset cell true))
(loop [x :range [x1 (+ 1 x2)]
:after (print)
y :range [y1 (+ 1 y2)]]
(file/write stdout (if (get cellset [x y]) "X " ". ")))
(print))
# Print the first 20 generations of a glider
(var *state* '[(0 0) (-1 0) (1 0) (1 1) (0 2)])
(for i 0 20
(print "generation " i)
(draw *state* -7 -7 7 7)
(set *state* (tick *state*)))
```
### TCP Echo Server
```janet
# A simple TCP echo server using the built-in socket networking and event loop.
(defn handler
"Simple handler for connections."
[stream]
(defer (:close stream)
(def id (gensym))
(def b @"")
(print "Connection " id "!")
(while (:read stream 1024 b)
(printf " %v -> %v" id b)
(:write stream b)
(buffer/clear b))
(printf "Done %v!" id)
(ev/sleep 0.5)))
(net/server "127.0.0.1" "8000" handler)
```
### Windows FFI Hello, World!
```janet
# Use the FFI to popup a Windows message box - no C required
(ffi/context "user32.dll")
(ffi/defbind MessageBoxA :int
[w :ptr text :string cap :string typ :int])
(MessageBoxA nil "Hello, World!" "Test" 0)
```
## Language Features
* 600+ functions and macros in the core library
* Built-in socket networking, threading, subprocesses, and file system functions.
* Parsing Expression Grammars (PEG) engine as a more robust Regex alternative
* Macros and compile-time computation
* Per-thread event loop for efficient IO (epoll/IOCP/kqueue)
* First-class green threads (continuations) as well as OS threads
* Erlang-style supervision trees that integrate with the event loop
* First-class closures
* Garbage collection
* First-class green threads (continuations)
* Distributed as janet.c and janet.h for embedding into a larger program.
* Python-style generators (implemented as a plain macro)
* Mutable and immutable arrays (array/tuple)
* Mutable and immutable hashtables (table/struct)
* Mutable and immutable strings (buffer/string)
* Macros
* Multithreading
* Per-thread event loop for efficient evented IO
* Byte code interpreter with an assembly interface, as well as bytecode verification
* Tail call Optimization
* Direct interop with C via abstract types and C functions
* Dynamically load C libraries
* Functional and imperative standard library
* Lexical scoping
* Imperative programming as well as functional
* REPL
* Parsing Expression Grammars built into the core library
* 400+ functions and macros in the core library
* Embedding Janet in other programs
* Interactive environment with detailed stack traces
* Tail recursion
* Interface with C functions and dynamically load plugins ("natives").
* Built-in C FFI for when the native bindings are too much work
* REPL development with debugger and inspectable runtime
## Documentation
* For a quick tutorial, see [the introduction](https://janet-lang.org/docs/index.html) for more details.
* For the full API for all functions in the core library, see [the core API doc](https://janet-lang.org/api/index.html)
* For the full API for all functions in the core library, see [the core API doc](https://janet-lang.org/api/index.html).
Documentation is also available locally in the REPL.
Use the `(doc symbol-name)` macro to get API
@@ -65,7 +138,7 @@ documentation for symbols in the core library. For example,
```
(doc apply)
```
Shows documentation for the `apply` function.
shows documentation for the `apply` function.
To get a list of all bindings in the default
environment, use the `(all-bindings)` function. You
@@ -84,7 +157,7 @@ the SourceHut mirror is actively maintained.
The Makefile is non-portable and requires GNU-flavored make.
```
```sh
cd somewhere/my/projects/janet
make
make test
@@ -100,7 +173,7 @@ Find out more about the available make targets by running `make help`.
32-bit Haiku build instructions are the same as the UNIX-like build instructions,
but you need to specify an alternative compiler, such as `gcc-x86`.
```
```sh
cd somewhere/my/projects/janet
make CC=gcc-x86
make test
@@ -112,10 +185,9 @@ make install-jpm-git
### FreeBSD
FreeBSD build instructions are the same as the UNIX-like build instructions,
but you need `gmake` to compile. Alternatively, install directly from
packages, using `pkg install lang/janet`.
but you need `gmake` to compile. Alternatively, install the package directly with `pkg install lang/janet`.
```
```sh
cd somewhere/my/projects/janet
gmake
gmake test
@@ -127,19 +199,19 @@ gmake install-jpm-git
### NetBSD
NetBSD build instructions are the same as the FreeBSD build instructions.
Alternatively, install directly from packages, using `pkgin install janet`.
Alternatively, install the package directly with `pkgin install janet`.
### Windows
1. Install [Visual Studio](https://visualstudio.microsoft.com/thank-you-downloading-visual-studio/?sku=Community&rel=15#) or [Visual Studio Build Tools](https://visualstudio.microsoft.com/thank-you-downloading-visual-studio/?sku=BuildTools&rel=15#)
2. Run a Visual Studio Command Prompt (cl.exe and link.exe need to be on the PATH) and cd to the directory with janet.
3. Run `build_win` to compile janet.
1. Install [Visual Studio](https://visualstudio.microsoft.com/thank-you-downloading-visual-studio/?sku=Community&rel=15#) or [Visual Studio Build Tools](https://visualstudio.microsoft.com/thank-you-downloading-visual-studio/?sku=BuildTools&rel=15#).
2. Run a Visual Studio Command Prompt (`cl.exe` and `link.exe` need to be on your PATH) and `cd` to the directory with Janet.
3. Run `build_win` to compile Janet.
4. Run `build_win test` to make sure everything is working.
To build an `.msi` installer executable, in addition to the above steps, you will have to:
5. Install, or otherwise add to your PATH the [WiX 3.11 Toolset](https://github.com/wixtoolset/wix3/releases)
6. run `build_win dist`
5. Install, or otherwise add to your PATH the [WiX 3.11 Toolset](https://github.com/wixtoolset/wix3/releases).
6. Run `build_win dist`.
Now you should have an `.msi`. You can run `build_win install` to install the `.msi`, or execute the file itself.
@@ -175,9 +247,9 @@ ninja -C build install
Janet can be hacked on with pretty much any environment you like, but for IDE
lovers, [Gnome Builder](https://wiki.gnome.org/Apps/Builder) is probably the
best option, as it has excellent meson integration. It also offers code completion
best option, as it has excellent Meson integration. It also offers code completion
for Janet's C API right out of the box, which is very useful for exploring. VSCode, Vim,
Emacs, and Atom will have syntax packages for the Janet language, though.
Emacs, and Atom each have syntax packages for the Janet language, though.
## Installation
@@ -186,8 +258,8 @@ to try out the language, you don't need to install anything. You can also move t
## Usage
A REPL is launched when the binary is invoked with no arguments. Pass the -h flag
to display the usage information. Individual scripts can be run with `./janet myscript.janet`
A REPL is launched when the binary is invoked with no arguments. Pass the `-h` flag
to display the usage information. Individual scripts can be run with `./janet myscript.janet`.
If you are looking to explore, you can print a list of all available macros, functions, and constants
by entering the command `(all-bindings)` into the REPL.
@@ -202,20 +274,26 @@ Hello, World!
nil
janet:3:> (os/exit)
$ janet -h
usage: build/janet [options] script args...
usage: janet [options] script args...
Options are:
-h : Show this help
-v : Print the version string
-s : Use raw stdin instead of getline like functionality
-e code : Execute a string of janet
-E code arguments... : Evaluate an expression as a short-fn with arguments
-d : Set the debug flag in the REPL
-r : Enter the REPL after running all scripts
-R : Disables loading profile.janet when JANET_PROFILE is present
-p : Keep on executing if there is a top-level error (persistent)
-q : Hide prompt, logo, and REPL output (quiet)
-q : Hide logo (quiet)
-k : Compile scripts but do not execute (flycheck)
-m syspath : Set system path for loading global modules
-c source output : Compile janet source code into an image
-i : Load the script argument as an image file instead of source code
-n : Disable ANSI color output in the REPL
-l path : Execute code in a file before running the main script
-l lib : Use a module before processing more arguments
-w level : Set the lint warning level - default is "normal"
-x level : Set the lint error level - default is "none"
-- : Stop handling options
```
@@ -226,8 +304,8 @@ If installed, you can also run `man janet` to get usage information.
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
`src/include/janet.h` and `src/conf/janetconf.h` can be dragged into any C
project and compiled into the project. Janet should be compiled with `-std=c99`
`src/include/janet.h` and `src/conf/janetconf.h`, can be dragged into any C
project and compiled into it. Janet should be compiled with `-std=c99`
on most compilers, and will need to be linked to the math library, `-lm`, and
the dynamic linker, `-ldl`, if one wants to be able to load dynamic modules. If
there is no need for dynamic modules, add the define
@@ -235,26 +313,36 @@ there is no need for dynamic modules, add the define
See the [Embedding Section](https://janet-lang.org/capi/embedding.html) on the website for more information.
## Examples
See the examples directory for some example janet code.
## Discussion
Feel free to ask questions and join the discussion on the [Janet Gitter Channel](https://gitter.im/janet-language/community).
Gitter provides Matrix and irc bridges as well.
Feel free to ask questions and join the discussion on the [Janet Gitter channel](https://gitter.im/janet-language/community).
Gitter provides Matrix and IRC bridges as well.
## FAQ
### How fast is it?
It is about the same speed as most interpreted languages without a JIT compiler. Tight, critical
loops should probably be written in C or C++ . Programs tend to be a bit faster than
they would be in a language like Python due to the discouragement of slow Object-Oriented abstraction
with lots of hash-table lookups, and making late-binding explicit. All values are boxed in an 8-byte
representation by default and allocated on the heap, with the exception of numbers, nils and booleans. The
PEG engine is a specialized interpreter that can efficiently process string and buffer data.
The GC is simple and stop-the-world, but GC knobs are exposed in the core library and separate threads
have isolated heaps and garbage collectors. Data that is shared between threads is reference counted.
YMMV.
### Where is (favorite feature from other language)?
It may exist, it may not. If you want to propose major language features, go ahead and open an issue, but
they will likely by closed as "will not implement". Often, such features make one usecase simpler at the expense
It may exist, it may not. If you want to propose a major language feature, go ahead and open an issue, but
it will likely be closed as "will not implement". Often, such features make one usecase simpler at the expense
of 5 others by making the language more complicated.
### Is there a language spec?
There is not currently a spec besides the documentation at https://janet-lang.org.
There is not currently a spec besides the documentation at <https://janet-lang.org>.
### Is this Scheme/Common Lisp? Where are the cons cells?
@@ -263,20 +351,20 @@ Nope. There are no cons cells here.
### Is this a Clojure port?
No. It's similar to Clojure superficially because I like Lisps and I like the aesthetics.
Internally, Janet is not at all like Clojure.
Internally, Janet is not at all like Clojure, Scheme, or Common Lisp.
### Are the immutable data structures (tuples and structs) implemented as hash tries?
No. They are immutable arrays and hash tables. Don't try and use them like Clojure's vectors
and maps, instead they work well as table keys or other identifiers.
### Can I do Object Oriented programming with Janet?
### Can I do object-oriented programming with Janet?
To some extent, yes. However, it is not the recommended method of abstraction, and performance may suffer.
That said, tables can be used to make mutable objects with inheritance and polymorphism, where object
methods are implemeted with keywords.
methods are implemented with keywords.
```
```clj
(def Car @{:honk (fn [self msg] (print "car " self " goes " msg)) })
(def my-car (table/setproto @{} Car))
(:honk my-car "Beep!")
@@ -287,17 +375,25 @@ methods are implemeted with keywords.
Usually, one of a few reasons:
- Often, it already exists in a different form and the Clojure port would be redundant.
- Clojure programs often generate a lot of garbage and rely on the JVM to clean it up.
Janet does not run on the JVM, and has a more primitive garbage collector.
- We want to keep the Janet core small. With Lisps, usually a feature can be added as a library
without feeling "bolted on", especially when compared to ALGOL like languages. Adding features
Janet does not run on the JVM and has a more primitive garbage collector.
- We want to keep the Janet core small. With Lisps, a feature can usually be added as a library
without feeling "bolted on", especially when compared to ALGOL-like languages. Adding features
to the core also makes it a bit more difficult to keep Janet maximally portable.
### Can I bind to Rust/Zig/Go/Java/Nim/C++/D/Pascal/Fortran/Odin/Jai/(Some new "Systems" Programming Language)?
Probably, if that language has a good interface with C. But the programmer may need to do
some extra work to map Janet's internal memory model may need some to that of the bound language. Janet
also uses `setjmp`/`longjmp` for non-local returns internally. This
approach is out of favor with many programmers now and doesn't always play well with other languages
that have exceptions or stack-unwinding.
### Why is my terminal spitting out junk when I run the REPL?
Make sure your terminal supports ANSI escape codes. Most modern terminals will
support these, but some older terminals, Windows consoles, or embedded terminals
will not. If your terminal does not support ANSI escape codes, run the REPL with
the `-n` flag, which disables color output. You can also try the `-s` if further issues
the `-n` flag, which disables color output. You can also try the `-s` flag if further issues
ensue.
## Why is it called "Janet"?

View File

@@ -78,7 +78,6 @@ double double_lots(
return i + j;
}
EXPORTER
double double_lots_2(
double a,
@@ -204,5 +203,3 @@ EXPORTER
int sixints_fn_3(SixInts s, int x) {
return x + s.u + s.v + s.w + s.x + s.y + s.z;
}

BIN
examples/jitfn/hello.bin Normal file

Binary file not shown.

17
examples/jitfn/hello.nasm Normal file
View File

@@ -0,0 +1,17 @@
BITS 64
;;;
;;; Code
;;;
mov rax, 1 ; write(
mov rdi, 1 ; STDOUT_FILENO,
lea rsi, [rel msg] ; msg,
mov rdx, msglen ; sizeof(msg)
syscall ; );
ret ; return;
;;;
;;; Constants
;;;
msg: db "Hello, world!", 10
msglen: equ $ - msg

View File

@@ -0,0 +1,13 @@
###
### Relies on NASM being installed to assemble code.
### Only works on x86-64 Linux.
###
### Before running, compile hello.nasm to hello.bin with
### $ nasm hello.nasm -o hello.bin
(def bin (slurp "hello.bin"))
(def f (ffi/jitfn bin))
(def signature (ffi/signature :default :void))
(ffi/call f signature)
(print "called a jitted function with FFI!")
(print "machine code: " (describe (string/slice f)))

10
janet.1
View File

@@ -183,6 +183,10 @@ default repl.
.BR \-n
Disable ANSI colors in the repl. Has no effect if no repl is run.
.TP
.BR \-N
Enable ANSI colors in the repl. Has no effect if no repl is run.
.TP
.BR \-r
Open a REPL (Read Eval Print Loop) after executing all sources. By default, if Janet is called with no
@@ -268,5 +272,11 @@ 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 NO_COLOR
.RS
Turn off color by default in the repl and in the error handler of scripts. This can be changed at runtime
via dynamic bindings *err-color* and *pretty-format*, or via the command line parameters -n and -N.
.RE
.SH AUTHOR
Written by Calvin Rose <calsrose@gmail.com>

View File

@@ -1,4 +1,4 @@
# Copyright (c) 2021 Calvin Rose and contributors
# Copyright (c) 2023 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.25.0')
version : '1.29.1')
# Global settings
janet_path = join_paths(get_option('prefix'), get_option('libdir'), 'janet')
@@ -77,6 +77,7 @@ conf.set('JANET_EV_NO_EPOLL', not get_option('epoll'))
conf.set('JANET_EV_NO_KQUEUE', not get_option('kqueue'))
conf.set('JANET_NO_INTERPRETER_INTERRUPT', not get_option('interpreter_interrupt'))
conf.set('JANET_NO_FFI', not get_option('ffi'))
conf.set('JANET_NO_FFI_JIT', not get_option('ffi_jit'))
if get_option('os_name') != ''
conf.set('JANET_OS_NAME', get_option('os_name'))
endif
@@ -226,17 +227,34 @@ docs = custom_target('docs',
# Tests
test_files = [
'test/suite0000.janet',
'test/suite0001.janet',
'test/suite0002.janet',
'test/suite0003.janet',
'test/suite0004.janet',
'test/suite0005.janet',
'test/suite0006.janet',
'test/suite0007.janet',
'test/suite0008.janet',
'test/suite0009.janet',
'test/suite0010.janet'
'test/suite-array.janet',
'test/suite-asm.janet',
'test/suite-boot.janet',
'test/suite-buffer.janet',
'test/suite-capi.janet',
'test/suite-cfuns.janet',
'test/suite-compile.janet',
'test/suite-corelib.janet',
'test/suite-debug.janet',
'test/suite-ev.janet',
'test/suite-ffi.janet',
'test/suite-inttypes.janet',
'test/suite-io.janet',
'test/suite-marsh.janet',
'test/suite-math.janet',
'test/suite-os.janet',
'test/suite-parse.janet',
'test/suite-peg.janet',
'test/suite-pp.janet',
'test/suite-specials.janet',
'test/suite-string.janet',
'test/suite-strtod.janet',
'test/suite-struct.janet',
'test/suite-symcache.janet',
'test/suite-table.janet',
'test/suite-unknown.janet',
'test/suite-value.janet',
'test/suite-vm.janet'
]
foreach t : test_files
test(t, janet_nativeclient, args : files([t]), workdir : meson.current_source_dir())

View File

@@ -20,6 +20,7 @@ option('epoll', type : 'boolean', value : false)
option('kqueue', type : 'boolean', value : false)
option('interpreter_interrupt', type : 'boolean', value : false)
option('ffi', type : 'boolean', value : true)
option('ffi_jit', type : 'boolean', value : true)
option('recursion_guard', type : 'integer', min : 10, max : 8000, value : 1024)
option('max_proto_depth', type : 'integer', min : 10, max : 8000, value : 200)

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
# The core janet library
# Copyright 2022 © Calvin Rose
# Copyright 2023 © Calvin Rose
###
###
@@ -129,30 +129,28 @@
# For macros, we define an imcomplete odd? function that will be overriden.
(defn odd? [x] (= 1 (mod x 2)))
(def idempotent?
```
(idempotent? x)
(def- non-atomic-types
{:array true
:tuple true
:table true
:buffer true
:symbol true
:struct true})
Check if x is a value that evaluates to itself when compiled.
```
(do
(def non-atomic-types
{:array true
:tuple true
:table true
:buffer true
:struct true})
(fn idempotent? [x] (not (in non-atomic-types (type x))))))
(defn idempotent?
"Check if x is a value that evaluates to itself when compiled."
[x]
(not (in non-atomic-types (type x))))
# C style macros and functions for imperative sugar. No bitwise though.
(defn inc "Returns x + 1." [x] (+ x 1))
(defn dec "Returns x - 1." [x] (- x 1))
(defmacro ++ "Increments the var x by 1." [x] ~(set ,x (,+ ,x ,1)))
(defmacro -- "Decrements the var x by 1." [x] ~(set ,x (,- ,x ,1)))
(defmacro += "Increments the var x by n." [x n] ~(set ,x (,+ ,x ,n)))
(defmacro -= "Decrements the var x by n." [x n] ~(set ,x (,- ,x ,n)))
(defmacro *= "Shorthand for (set x (\\* x n))." [x n] ~(set ,x (,* ,x ,n)))
(defmacro /= "Shorthand for (set x (/ x n))." [x n] ~(set ,x (,/ ,x ,n)))
(defmacro += "Increments the var x by n." [x & ns] ~(set ,x (,+ ,x ,;ns)))
(defmacro -= "Decrements the var x by n." [x & ns] ~(set ,x (,- ,x ,;ns)))
(defmacro *= "Shorthand for (set x (\\* x n))." [x & ns] ~(set ,x (,* ,x ,;ns)))
(defmacro /= "Shorthand for (set x (/ x n))." [x & ns] ~(set ,x (,/ ,x ,;ns)))
(defmacro %= "Shorthand for (set x (% x n))." [x n] ~(set ,x (,% ,x ,n)))
(defmacro assert
@@ -282,7 +280,7 @@
(while (> i 0)
(-- i)
(def v (in forms i))
(set ret (if (= ret true)
(set ret (if (= i (- len 1))
v
(if (idempotent? v)
['if v ret v]
@@ -447,7 +445,7 @@
,(case kind
:each ~(,in ,ds ,k)
:keys k
:pairs ~(,tuple ,k (,in ,ds ,k))))
:pairs ~[,k (,in ,ds ,k)]))
,;body
(set ,k (,next ,ds ,k))))))
@@ -613,6 +611,13 @@
(def $accum (gensym))
~(do (def ,$accum @[]) (loop ,head (,array/push ,$accum (do ,;body))) ,$accum))
(defmacro catseq
``Similar to `loop`, but concatenates each element from the loop body into an array and returns that.
See `loop` for details.``
[head & body]
(def $accum (gensym))
~(do (def ,$accum @[]) (loop ,head (,array/concat ,$accum (do ,;body))) ,$accum))
(defmacro tabseq
``Similar to `loop`, but accumulates key value pairs into a table.
See `loop` for details.``
@@ -663,28 +668,20 @@
(def len (length bindings))
(if (= 0 len) (error "expected at least 1 binding"))
(if (odd? len) (error "expected an even number of bindings"))
(def res (gensym))
(defn aux [i]
(if (>= i len)
tru
~(do (set ,res ,tru) true)
(do
(def bl (in bindings i))
(def br (in bindings (+ 1 i)))
(def atm (idempotent? bl))
(def sym (if atm bl (gensym)))
(if atm
# Simple binding
(tuple 'do
(tuple 'def sym br)
(tuple 'if sym (aux (+ 2 i)) fal))
# Destructured binding
(tuple 'do
(tuple 'def sym br)
(tuple 'if sym
(tuple 'do
(tuple 'def bl sym)
(aux (+ 2 i)))
fal))))))
(aux 0))
(if (symbol? bl)
~(if (def ,bl ,br) ,(aux (+ 2 i)))
~(if (def ,(def sym (gensym)) ,br)
(do (def ,bl ,sym) ,(aux (+ 2 i))))))))
~(do
(var ,res nil)
(if ,(aux 0) ,res ,fal)))
(defmacro when-let
"Same as `(if-let bindings (do ;body))`."
@@ -839,15 +836,15 @@
a)
(defn sort
``Sort `ind` in-place, and return it. Uses quick-sort and is not a stable 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?]
(sort-help ind 0 (- (length ind) 1) (or before? <)))
(defn sort-by
``Returns `ind` sorted by calling
a function `f` on each element and comparing the result with `<`.``
``Sorts `ind` in-place by calling a function `f` on each element and
comparing the result with `<`.``
[f ind]
(sort ind (fn [x y] (< (f x) (f y)))))
@@ -918,67 +915,68 @@
(set k (next ind k)))
ret)
(defmacro- map-aggregator
`Aggregation logic for various map functions.`
[maptype res val]
(case maptype
:map ~(array/push ,res ,val)
:mapcat ~(array/concat ,res ,val)
:keep ~(if (def y ,val) (array/push ,res y))
:count ~(if ,val (++ ,res))
:some ~(if (def y ,val) (do (set ,res y) (break)))
:all ~(if (def y ,val) nil (do (set ,res y) (break)))))
(defmacro- map-n
`Generates efficient map logic for a specific number of
indexed beyond the first.`
[n maptype res f ind inds]
~(do
(def ,(seq [k :range [0 n]] (symbol 'ind k)) ,inds)
,;(seq [k :range [0 n]] ~(var ,(symbol 'key k) nil))
(each x ,ind
,;(seq [k :range [0 n]]
~(if (= nil (set ,(symbol 'key k) (next ,(symbol 'ind k) ,(symbol 'key k)))) (break)))
(map-aggregator ,maptype ,res (,f x ,;(seq [k :range [0 n]] ~(in ,(symbol 'ind k) ,(symbol 'key k))))))))
(defmacro- map-template
[maptype res f ind inds]
~(do
(def ninds (length ,inds))
(case ninds
0 (each x ,ind (map-aggregator ,maptype ,res (,f x)))
1 (map-n 1 ,maptype ,res ,f ,ind ,inds)
2 (map-n 2 ,maptype ,res ,f ,ind ,inds)
3 (map-n 3 ,maptype ,res ,f ,ind ,inds)
4 (map-n 4 ,maptype ,res ,f ,ind ,inds)
(do
(def iter-keys (array/new-filled ninds))
(def call-buffer (array/new-filled ninds))
(var done false)
(each x ,ind
(forv i 0 ninds
(let [old-key (in iter-keys i)
ii (in ,inds i)
new-key (next ii old-key)]
(if (= nil new-key)
(do (set done true) (break))
(do (set (iter-keys i) new-key) (set (call-buffer i) (in ii new-key))))))
(if done (break))
(map-aggregator ,maptype ,res (,f x ;call-buffer)))))))
(defn map
`Map a function over every value in a data structure and
return an array of the results.`
[f & inds]
(def ninds (length inds))
(if (= 0 ninds) (error "expected at least 1 indexed collection"))
[f ind & inds]
(def res @[])
(def [i1 i2 i3 i4] inds)
(case ninds
1 (each x i1 (array/push res (f x)))
2 (do
(var k1 nil)
(var k2 nil)
(while true
(if (= nil (set k1 (next i1 k1))) (break))
(if (= nil (set k2 (next i2 k2))) (break))
(array/push res (f (in i1 k1) (in i2 k2)))))
3 (do
(var k1 nil)
(var k2 nil)
(var k3 nil)
(while true
(if (= nil (set k1 (next i1 k1))) (break))
(if (= nil (set k2 (next i2 k2))) (break))
(if (= nil (set k3 (next i3 k3))) (break))
(array/push res (f (in i1 k1) (in i2 k2) (in i3 k3)))))
4 (do
(var k1 nil)
(var k2 nil)
(var k3 nil)
(var k4 nil)
(while true
(if (= nil (set k1 (next i1 k1))) (break))
(if (= nil (set k2 (next i2 k2))) (break))
(if (= nil (set k3 (next i3 k3))) (break))
(if (= nil (set k4 (next i4 k4))) (break))
(array/push res (f (in i1 k1) (in i2 k2) (in i3 k3) (in i4 k4)))))
(do
(def iterkeys (array/new-filled ninds))
(var done false)
(def call-buffer @[])
(while true
(forv i 0 ninds
(let [old-key (in iterkeys i)
ii (in inds i)
new-key (next ii old-key)]
(if (= nil new-key)
(do (set done true) (break))
(do (set (iterkeys i) new-key) (array/push call-buffer (in ii new-key))))))
(if done (break))
(array/push res (f ;call-buffer))
(array/clear call-buffer))))
(map-template :map res f ind inds)
res)
(defn mapcat
``Map a function over every element in an array or tuple and
use `array/concat` to concatenate the results.``
[f ind]
[f ind & inds]
(def res @[])
(each x ind
(array/concat res (f x)))
(map-template :mapcat res f ind inds)
res)
(defn filter
@@ -994,23 +992,19 @@
(defn count
``Count the number of items in `ind` for which `(pred item)`
is true.``
[pred ind]
(var counter 0)
(each item ind
(if (pred item)
(++ counter)))
counter)
[pred ind & inds]
(var res 0)
(map-template :count res pred ind inds)
res)
(defn keep
``Given a predicate `pred`, return a new array containing the truthy results
of applying `pred` to each element in the indexed collection `ind`. This is
different from `filter` which returns an array of the original elements where
the predicate is truthy.``
[pred ind]
[pred ind & inds]
(def res @[])
(each item ind
(if-let [y (pred item)]
(array/push res y)))
(map-template :keep res pred ind inds)
res)
(defn range
@@ -1078,42 +1072,33 @@
(set k (next ind k)))
ret)
(defn- take-n-fallback
[n xs]
(def res @[])
(when (> n 0)
(var left n)
(each x xs
(array/push res x)
(-- left)
(if (= 0 left) (break))))
res)
(defn- take-until-fallback
[pred xs]
(def res @[])
(each x xs
(if (pred x) (break))
(array/push res x))
res)
(defn- slice-n
(defn- take-n-slice
[f n ind]
(def len (length ind))
# make sure end is in [0, len]
(def m (if (> n 0) n 0))
(def end (if (> m len) len m))
(f ind 0 end))
(def m (+ len n))
(def start (if (< n 0 m) m 0))
(def end (if (<= 0 n len) n len))
(f ind start end))
(defn take
"Take the first n elements of a fiber, indexed or bytes type. Returns a new array, tuple or string, respectively."
``Take the first n elements of a fiber, indexed or bytes type. Returns a new array, tuple or string,
respectively. If `n` is negative, takes the last `n` elements instead.``
[n ind]
(cond
(bytes? ind) (slice-n string/slice n ind)
(indexed? ind) (slice-n tuple/slice n ind)
(take-n-fallback n ind)))
(indexed? ind) (take-n-slice tuple/slice n ind)
(bytes? ind) (take-n-slice string/slice n ind)
(dictionary? ind) (do
(var left n)
(tabseq [[i x] :pairs ind :until (< (-- left) 0)] i x))
(do
(def res @[])
(var key nil)
(repeat n
(if (= nil (set key (next ind key))) (break))
(array/push res (in ind key)))
res)))
(defn- slice-until
(defn- take-until-slice
[f pred ind]
(def len (length ind))
(def i (find-index pred ind))
@@ -1124,9 +1109,10 @@
"Same as `(take-while (complement pred) ind)`."
[pred ind]
(cond
(bytes? ind) (slice-until string/slice pred ind)
(indexed? ind) (slice-until tuple/slice pred ind)
(take-until-fallback pred ind)))
(indexed? ind) (take-until-slice tuple/slice pred ind)
(bytes? ind) (take-until-slice string/slice pred ind)
(dictionary? ind) (tabseq [[i x] :pairs ind :until (pred x)] i x)
(seq [x :in ind :until (pred x)] x)))
(defn take-while
`Given a predicate, take only elements from a fiber, indexed, or bytes type that satisfy
@@ -1134,27 +1120,58 @@
[pred ind]
(take-until (complement pred) ind))
(defn drop
``Drop the first n elements in an indexed or bytes type. Returns a new tuple or string
instance, respectively.``
[n ind]
(def use-str (bytes? ind))
(def f (if use-str string/slice tuple/slice))
(defn- drop-n-slice
[f n ind]
(def len (length ind))
# make sure start is in [0, len]
(def m (if (> n 0) n 0))
(def start (if (> m len) len m))
(f ind start -1))
(cond
(<= 0 n len) (f ind n)
(< (- len) n 0) (f ind 0 (+ len n))
(f ind len)))
(defn- drop-n-dict
[f n ind]
(def res (f ind))
(var left n)
(loop [[i x] :pairs ind :until (< (-- left) 0)] (set (res i) nil))
res)
(defn drop
``Drop the first `n` elements in an indexed or bytes type. Returns a new tuple or string
instance, respectively. If `n` is negative, drops the last `n` elements instead.``
[n ind]
(cond
(indexed? ind) (drop-n-slice tuple/slice n ind)
(bytes? ind) (drop-n-slice string/slice n ind)
(struct? ind) (drop-n-dict struct/to-table n ind)
(table? ind) (drop-n-dict table/clone n ind)
(do
(var key nil)
(repeat n
(if (= nil (set key (next ind key))) (break)))
ind)))
(defn- drop-until-slice
[f pred ind]
(def len (length ind))
(def i (find-index pred ind))
(def start (if (nil? i) len i))
(f ind start))
(defn- drop-until-dict
[f pred ind]
(def res (f ind))
(loop [[i x] :pairs ind :until (pred x)] (set (res i) nil))
res)
(defn drop-until
"Same as `(drop-while (complement pred) ind)`."
[pred ind]
(def use-str (bytes? ind))
(def f (if use-str string/slice tuple/slice))
(def i (find-index pred ind))
(def len (length ind))
(def start (if (nil? i) len i))
(f ind start))
(cond
(indexed? ind) (drop-until-slice tuple/slice pred ind)
(bytes? ind) (drop-until-slice string/slice pred ind)
(struct? ind) (drop-until-dict struct/to-table pred ind)
(table? ind) (drop-until-dict table/clone pred ind)
(do (find pred ind) ind)))
(defn drop-while
`Given a predicate, remove elements from an indexed or bytes type that satisfy
@@ -1194,6 +1211,16 @@
(def kw (keyword prefix (slice alias 1 -2)))
~(def ,alias :dyn ,;more ,kw))
(defn has-key?
"Check if a data structure `ds` contains the key `key`."
[ds key]
(not= nil (get ds key)))
(defn has-value?
"Check if a data structure `ds` contains the value `value`. Will run in time proportional to the size of `ds`."
[ds value]
(not= nil (index-of value ds)))
(defdyn *defdyn-prefix* ``Optional namespace prefix to add to keywords declared with `defdyn`.
Use this to prevent keyword collisions between dynamic bindings.``)
(defdyn *out* "Where normal print functions print output to.")
@@ -1202,6 +1229,7 @@
(defdyn *debug* "Enables a built in debugger on errors and other useful features for debugging in a repl.")
(defdyn *exit* "When set, will cause the current context to complete. Can be set to exit from repl (or file), for example.")
(defdyn *exit-value* "Set the return value from `run-context` upon an exit. By default, `run-context` will return nil.")
(defdyn *task-id* "When spawning a thread or fiber, the task-id can be assigned for concurrecny control.")
(defdyn *macro-form*
"Inside a macro, is bound to the source form that invoked the macro")
@@ -1234,6 +1262,29 @@
(,eprintf (,dyn :pretty-format "%q") ,s)
,s))
(defn keep-syntax
``Creates a tuple with the tuple type and sourcemap of `before` but the
elements of `after`. If either one of its argements is not a tuple, returns
`after` unmodified. Useful to preserve syntactic information when transforming
an ast in macros.``
[before after]
(if (and (= :tuple (type before))
(= :tuple (type after)))
(do
(def res (if (= :parens (tuple/type before))
(tuple/slice after)
(tuple/brackets ;after)))
(tuple/setmap res ;(tuple/sourcemap before)))
after))
(defn keep-syntax!
``Like `keep-syntax`, but if `after` is an array, it is coerced into a tuple.
Useful to preserve syntactic information when transforming an ast in macros.``
[before after]
(keep-syntax before (if (= :array (type after))
(tuple/slice after)
after)))
(defmacro ->
``Threading macro. Inserts x as the second value in the first form
in `forms`, and inserts the modified first form into the second form
@@ -1244,7 +1295,7 @@
(tuple (in n 0) (array/slice n 1))
(tuple n @[])))
(def parts (array/concat @[h last] t))
(tuple/slice parts 0))
(keep-syntax! n parts))
(reduce fop x forms))
(defmacro ->>
@@ -1257,7 +1308,7 @@
(tuple (in n 0) (array/slice n 1))
(tuple n @[])))
(def parts (array/concat @[h] t @[last]))
(tuple/slice parts 0))
(keep-syntax! n parts))
(reduce fop x forms))
(defmacro -?>
@@ -1273,7 +1324,7 @@
(tuple n @[])))
(def sym (gensym))
(def parts (array/concat @[h sym] t))
~(let [,sym ,last] (if ,sym ,(tuple/slice parts 0))))
~(let [,sym ,last] (if ,sym ,(keep-syntax! n parts))))
(reduce fop x forms))
(defmacro -?>>
@@ -1289,7 +1340,7 @@
(tuple n @[])))
(def sym (gensym))
(def parts (array/concat @[h] t @[sym]))
~(let [,sym ,last] (if ,sym ,(tuple/slice parts 0))))
~(let [,sym ,last] (if ,sym ,(keep-syntax! n parts))))
(reduce fop x forms))
(defn- walk-ind [f form]
@@ -1313,10 +1364,7 @@
:table (walk-dict f form)
:struct (table/to-struct (walk-dict f form))
:array (walk-ind f form)
:tuple (let [x (walk-ind f form)]
(if (= :parens (tuple/type form))
(tuple/slice x)
(tuple/brackets ;x)))
:tuple (keep-syntax! form (walk-ind f form))
form))
(defn postwalk
@@ -1724,6 +1772,14 @@
(printf (dyn *pretty-format* "%q") x)
(flush))
(defn file/lines
"Return an iterator over the lines of a file."
[file]
(coro
(while (def line (file/read file :line))
(yield line))))
###
###
### Pattern Matching
@@ -2065,20 +2121,21 @@
ret)
(defn all
``Returns true if all `xs` are truthy, otherwise the result of first
falsey predicate value, `(pred x)`.``
[pred xs]
(var ret true)
(loop [x :in xs :while ret] (set ret (pred x)))
ret)
``Returns true if `(pred item)` is truthy for every item in `ind`.
Otherwise, returns the first falsey result encountered.
Returns true if `ind` is empty.``
[pred ind & inds]
(var res true)
(map-template :all res pred ind inds)
res)
(defn some
``Returns nil if all `xs` are false or nil, otherwise returns the result of the
first truthy predicate, `(pred x)`.``
[pred xs]
(var ret nil)
(loop [x :in xs :while (not ret)] (if-let [y (pred x)] (set ret y)))
ret)
``Returns nil if `(pred item)` is false or nil for every item in `ind`.
Otherwise, returns the first truthy result encountered.``
[pred ind & inds]
(var res nil)
(map-template :some res pred ind inds)
res)
(defn deep-not=
``Like `not=`, but mutable types (arrays, tables, buffers) are considered
@@ -2088,8 +2145,24 @@
(or
(not= tx (type y))
(case tx
:tuple (or (not= (length x) (length y)) (some identity (map deep-not= x y)))
:array (or (not= (length x) (length y)) (some identity (map deep-not= x y)))
:tuple (or (not= (length x) (length y))
(do
(var ret false)
(forv i 0 (length x)
(def xx (in x i))
(def yy (in y i))
(if (deep-not= xx yy)
(break (set ret true))))
ret))
:array (or (not= (length x) (length y))
(do
(var ret false)
(forv i 0 (length x)
(def xx (in x i))
(def yy (in y i))
(if (deep-not= xx yy)
(break (set ret true))))
ret))
:struct (deep-not= (kvs x) (kvs y))
:table (deep-not= (table/to-struct x) (table/to-struct y))
:buffer (not= (string x) (string y))
@@ -2116,6 +2189,19 @@
:buffer (string x)
x))
(defn thaw
`Thaw an object (make it mutable) and do a deep copy, making
child value also mutable. Closures, fibers, and abstract
types will not be recursively thawed, but all other types will`
[ds]
(case (type ds)
:array (walk-ind thaw ds)
:tuple (walk-ind thaw ds)
:table (walk-dict thaw (table/proto-flatten ds))
:struct (walk-dict thaw (struct/proto-flatten ds))
:string (buffer ds)
ds))
(defn macex
``Expand macros completely.
`on-binding` is an optional callback for whenever a normal symbolic binding
@@ -2183,6 +2269,7 @@
(defn saw-special-arg
[num]
(set max-param-seen (max max-param-seen num)))
(def prefix (gensym))
(defn on-binding
[x]
(if (string/has-prefix? '$ x)
@@ -2190,22 +2277,24 @@
(= '$ x)
(do
(saw-special-arg 0)
'$0)
(symbol prefix '$0))
(= '$& x)
(do
(set vararg true)
x)
(symbol prefix x))
:else
(do
(def num (scan-number (string/slice x 1)))
(if (nat? num)
(saw-special-arg num))
x))
(do
(saw-special-arg num)
(symbol prefix x))
x)))
x))
(def expanded (macex arg on-binding))
(def name-splice (if name [name] []))
(def fn-args (seq [i :range [0 (+ 1 max-param-seen)]] (symbol '$ i)))
~(fn ,;name-splice [,;fn-args ,;(if vararg ['& '$&] [])] ,expanded))
(def fn-args (seq [i :range [0 (+ 1 max-param-seen)]] (symbol prefix '$ i)))
~(fn ,;name-splice [,;fn-args ,;(if vararg ['& (symbol prefix '$&)] [])] ,expanded))
###
###
@@ -2456,8 +2545,8 @@
(set good false)
(def {:error err :line line :column column :fiber errf} res)
(on-compile-error err errf where (or line l) (or column c))))))
guard))
(fiber/setenv f env)
guard
env))
(while (fiber/can-resume? f)
(def res (resume f resumeval))
(when good (set resumeval (onstatus f res)))))
@@ -2534,7 +2623,7 @@
(in env :exit-value env))
(defn quit
``Tries to exit from the current repl or context. Does not always exit the application.
``Tries to exit from the current repl or run-context. Does not always exit the application.
Works by setting the :exit dynamic binding to true. Passing a non-nil `value` here will cause the outer
run-context to return that value.``
[&opt value]
@@ -2542,36 +2631,11 @@
(setdyn :exit-value value)
nil)
(defn eval-string
``Evaluates a string in the current environment. If more control over the
environment is needed, use `run-context`.``
[str]
(var state (string str))
(defn chunks [buf _]
(def ret state)
(set state nil)
(when ret
(buffer/push-string buf str)
(buffer/push-string buf "\n")))
(var returnval nil)
(run-context {:chunks chunks
:on-compile-error (fn compile-error [msg errf &]
(error (string "compile error: " msg)))
:on-parse-error (fn parse-error [p x]
(error (string "parse error: " (:error p))))
:fiber-flags :i
:on-status (fn on-status [f val]
(if-not (= (fiber/status f) :dead)
(error val))
(set returnval val))
:source :eval-string})
returnval)
(defn eval
``Evaluates a form in the current environment. If more control over the
environment is needed, use `run-context`.``
[form]
(def res (compile form (fiber/getenv (fiber/current)) :eval))
(def res (compile form nil :eval))
(if (= (type res) :function)
(res)
(error (get res :error))))
@@ -2582,6 +2646,8 @@
[str]
(let [p (parser/new)]
(parser/consume p str)
(if (= :error (parser/status p))
(error (parser/error p)))
(parser/eof p)
(if (parser/has-more p)
(parser/produce p)
@@ -2596,6 +2662,8 @@
(let [p (parser/new)
ret @[]]
(parser/consume p str)
(if (= :error (parser/status p))
(error (parser/error p)))
(parser/eof p)
(while (parser/has-more p)
(array/push ret (parser/produce p)))
@@ -2603,6 +2671,14 @@
(error (parser/error p))
ret)))
(defn eval-string
``Evaluates a string in the current environment. If more control over the
environment is needed, use `run-context`.``
[str]
(var ret nil)
(each x (parse-all str) (set ret (eval x)))
ret)
(def load-image-dict
``A table used in combination with `unmarshal` to unmarshal byte sequences created
by `make-image`, such that `(load-image bytes)` is the same as `(unmarshal bytes load-image-dict)`.``
@@ -2642,9 +2718,10 @@
[image]
(unmarshal image load-image-dict))
(defn- check-dyn-relative [x] (if (string/has-prefix? "@" x) x))
(defn- check-relative [x] (if (string/has-prefix? "." x) x))
(defn- check-not-relative [x] (if-not (string/has-prefix? "." x) x))
(defn- check-is-dep [x] (unless (or (string/has-prefix? "/" x) (string/has-prefix? "." 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))
(def module/cache
@@ -2678,6 +2755,8 @@
(defn- find-prefix
[pre]
(or (find-index |(and (string? ($ 0)) (string/has-prefix? pre ($ 0))) module/paths) 0))
(def dyn-index (find-prefix ":@all:"))
(array/insert module/paths dyn-index [(string ":@all:" ext) loader check-dyn-relative])
(def all-index (find-prefix ".:all:"))
(array/insert module/paths all-index [(string ".:all:" ext) loader check-project-relative])
(def sys-index (find-prefix ":sys:"))
@@ -2775,6 +2854,7 @@
(put nextenv :fiber fiber)
(put nextenv :debug-level level)
(put nextenv :signal (fiber/last-value fiber))
(merge-into nextenv debugger-env)
(defn debugger-chunks [buf p]
(def status (:state p :delimiters))
@@ -2803,7 +2883,7 @@
(if (= :dead fs)
(when is-repl
(put env '_ @{:value x})
(printf (get env :pretty-format "%q") x)
(printf (get env *pretty-format* "%q") x)
(flush))
(do
(debug/stacktrace f x "")
@@ -3148,16 +3228,17 @@
(cond
(or (= b (chr "\n")) (= b (chr " "))) (endtoken)
(= b (chr "`")) (delim :code)
(not (modes :code)) (cond
(not (modes :code))
(cond
(= b (chr `\`)) (do
(++ token-length)
(buffer/push token (get line (++ i))))
(= b (chr "_")) (delim :underline)
(= b (chr "*"))
(if (= (chr "*") (get line (+ i 1)))
(do (++ i)
(delim :bold))
(delim :italics))
(if (= (chr "*") (get line (+ i 1)))
(do (++ i)
(delim :bold))
(delim :italics))
(do (++ token-length) (buffer/push token b)))
(do (++ token-length) (buffer/push token b))))
(endtoken)
@@ -3383,11 +3464,16 @@
(print))
(defn .frame
"Show a stack frame."
"Show a stack frame"
[&opt n]
(def stack (debug/stack (.fiber)))
(in stack (or n 0)))
(defn .locals
"Show local bindings"
[&opt n]
(get (.frame n) :locals))
(defn .fn
"Get the current function."
[&opt n]
@@ -3592,13 +3678,22 @@
(,ev/deadline ,deadline nil ,f)
(,resume ,f))))
(defn- cancel-all [chan fibers reason]
(each f fibers (ev/cancel f reason))
(let [n (length fibers)]
(table/clear fibers)
(repeat n (ev/take chan))))
(defn- wait-for-fibers
[chan fibers]
(repeat (length fibers)
(def [sig fiber] (ev/take chan))
(unless (= sig :ok)
(each f fibers (ev/cancel f "sibling canceled"))
(propagate (fiber/last-value fiber) fiber))))
(defer (cancel-all chan fibers "parent canceled")
(repeat (length fibers)
(def [sig fiber] (ev/take chan))
(if (= sig :ok)
(put fibers fiber nil)
(do
(cancel-all chan fibers "sibling canceled")
(propagate (fiber/last-value fiber) fiber))))))
(defmacro ev/gather
``
@@ -3606,13 +3701,16 @@
Returns the gathered results in an array.
``
[& bodies]
(with-syms [chan res]
(with-syms [chan res fset ftemp]
~(do
(def ,fset @{})
(def ,chan (,ev/chan))
(def ,res @[])
(,wait-for-fibers ,chan
,(seq [[i body] :pairs bodies]
~(,ev/go (fn [] (put ,res ,i ,body)) nil ,chan)))
,;(seq [[i body] :pairs bodies]
~(do
(def ,ftemp (,ev/go (fn [] (put ,res ,i ,body)) nil ,chan))
(,put ,fset ,ftemp ,ftemp)))
(,wait-for-fibers ,chan ,fset)
,res))))
(compwhen (dyn 'net/listen)
@@ -3688,10 +3786,10 @@
(defn make-ptr []
(assert (ffi/lookup (if lazy (llib) lib) raw-symbol) (string "failed to find ffi symbol " raw-symbol)))
(if lazy
~(defn ,name ,;meta [,;formal-args]
(,ffi/call (,(delay (make-ptr))) (,(delay (make-sig))) ,;formal-args))
~(defn ,name ,;meta [,;formal-args]
(,ffi/call ,(make-ptr) ,(make-sig) ,;formal-args)))))
~(defn ,name ,;meta [,;formal-args]
(,ffi/call (,(delay (make-ptr))) (,(delay (make-sig))) ,;formal-args))
~(defn ,name ,;meta [,;formal-args]
(,ffi/call ,(make-ptr) ,(make-sig) ,;formal-args)))))
###
###
@@ -3785,8 +3883,7 @@
(def guard (if (get env :debug) :ydt :y))
(defn wrap-main [&]
(main ;subargs))
(def f (fiber/new wrap-main guard))
(fiber/setenv f env)
(def f (fiber/new wrap-main guard env))
(var res nil)
(while (fiber/can-resume? f)
(set res (resume f res))
@@ -3803,6 +3900,9 @@
(defdyn *profilepath*
"Path to profile file loaded when starting up the repl.")
(compwhen (not (dyn 'os/isatty))
(defmacro os/isatty [&] true))
(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.`
@@ -3825,6 +3925,9 @@
(if-let [jp (getenv-alias "JANET_PATH")] (setdyn *syspath* jp))
(if-let [jprofile (getenv-alias "JANET_PROFILE")] (setdyn *profilepath* jprofile))
(set colorize (and
(not (getenv-alias "NO_COLOR"))
(os/isatty stdout)))
(defn- get-lint-level
[i]
@@ -3842,7 +3945,7 @@
-v : Print the version string
-s : Use raw stdin instead of getline like functionality
-e code : Execute a string of janet
-E code arguments... : Evaluate an expression as a short-fn with arguments
-E code arguments... : Evaluate an expression as a short-fn with arguments
-d : Set the debug flag in the REPL
-r : Enter the REPL after running all scripts
-R : Disables loading profile.janet when JANET_PROFILE is present
@@ -3853,6 +3956,7 @@
-c source output : Compile janet source code into an image
-i : Load the script argument as an image file instead of source code
-n : Disable ANSI color output in the REPL
-N : Enable ANSI color output in the REPL
-l lib : Use a module before processing more arguments
-w level : Set the lint warning level - default is "normal"
-x level : Set the lint error level - default is "none"
@@ -3868,6 +3972,7 @@
"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)
"m" (fn [i &] (setdyn *syspath* (in args (+ i 1))) 2)
"c" (fn c-switch [i &]
(def path (in args (+ i 1)))
@@ -3942,7 +4047,7 @@
compile-only (flycheck stdin :source :stdin :exit exit-on-error)
(do
(if-not quiet
(print "Janet " janet/version "-" janet/build " " (os/which) "/" (os/arch) " - '(doc)' for help"))
(print "Janet " janet/version "-" janet/build " " (os/which) "/" (os/arch) "/" (os/compiler) " - '(doc)' for help"))
(flush)
(defn getprompt [p]
(def [line] (parser/where p))
@@ -4076,10 +4181,11 @@
(defn do-one-file
[fname]
(print "\n/* " fname " */")
(print "#line 0 \"" fname "\"\n")
(def source (slurp fname))
(print (string/replace-all "\r" "" source)))
(unless (has-value? boot/args "image-only")
(print "\n/* " fname " */")
(print "#line 0 \"" fname "\"\n")
(def source (slurp fname))
(print (string/replace-all "\r" "" source))))
(do-one-file feature-header)

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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,6 +70,5 @@ int system_test() {
assert(janet_equals(tuple1, tuple2));
return 0;
}

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -4,10 +4,10 @@
#define JANETCONF_H
#define JANET_VERSION_MAJOR 1
#define JANET_VERSION_MINOR 25
#define JANET_VERSION_PATCH 0
#define JANET_VERSION_MINOR 29
#define JANET_VERSION_PATCH 1
#define JANET_VERSION_EXTRA ""
#define JANET_VERSION "1.25.0"
#define JANET_VERSION "1.29.1"
/* #define JANET_BUILD "local" */
@@ -33,6 +33,8 @@
/* #define JANET_NO_SYMLINKS */
/* #define JANET_NO_UMASK */
/* #define JANET_NO_THREADS */
/* #define JANET_NO_FFI */
/* #define JANET_NO_FFI_JIT */
/* Other settings */
/* #define JANET_DEBUG */

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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,6 +31,8 @@
#ifdef JANET_EV
#ifdef JANET_WINDOWS
#include <windows.h>
#else
#include <stdatomic.h>
#endif
#endif
@@ -96,11 +98,11 @@ size_t janet_os_rwlock_size(void) {
}
static int32_t janet_incref(JanetAbstractHead *ab) {
return InterlockedIncrement(&ab->gc.data.refcount);
return InterlockedIncrement((LONG volatile *) &ab->gc.data.refcount);
}
static int32_t janet_decref(JanetAbstractHead *ab) {
return InterlockedDecrement(&ab->gc.data.refcount);
return InterlockedDecrement((LONG volatile *) &ab->gc.data.refcount);
}
void janet_os_mutex_init(JanetOSMutex *mutex) {

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -187,7 +187,11 @@ static void janet_asm_longjmp(JanetAssembler *a) {
/* Throw some kind of assembly error */
static void janet_asm_error(JanetAssembler *a, const char *message) {
a->errmessage = janet_formatc("%s, instruction %d", message, a->errindex);
if (a->errindex < 0) {
a->errmessage = janet_formatc("%s", message);
} else {
a->errmessage = janet_formatc("%s, instruction %d", message, a->errindex);
}
janet_asm_longjmp(a);
}
#define janet_asm_assert(a, c, m) do { if (!(c)) janet_asm_error((a), (m)); } while (0)
@@ -516,6 +520,7 @@ static JanetAssembleResult janet_asm1(JanetAssembler *parent, Janet source, int
#endif
if (NULL != a.parent) {
janet_asm_deinit(&a);
a.parent->errmessage = a.errmessage;
janet_asm_longjmp(a.parent);
}
result.funcdef = NULL;
@@ -601,6 +606,9 @@ static JanetAssembleResult janet_asm1(JanetAssembler *parent, Janet source, int
/* Parse sub funcdefs */
x = janet_get1(s, janet_ckeywordv("closures"));
if (janet_checktype(x, JANET_NIL)) {
x = janet_get1(s, janet_ckeywordv("defs"));
}
if (janet_indexed_view(x, &arr, &count)) {
int32_t i;
for (i = 0; i < count; i++) {
@@ -713,10 +721,63 @@ static JanetAssembleResult janet_asm1(JanetAssembler *parent, Janet source, int
}
}
/* Set symbolmap */
def->symbolmap = NULL;
def->symbolmap_length = 0;
x = janet_get1(s, janet_ckeywordv("symbolmap"));
if (janet_indexed_view(x, &arr, &count)) {
def->symbolmap_length = count;
def->symbolmap = janet_malloc(sizeof(JanetSymbolMap) * (size_t)count);
if (NULL == def->symbolmap) {
JANET_OUT_OF_MEMORY;
}
for (i = 0; i < count; i++) {
const Janet *tup;
Janet entry = arr[i];
JanetSymbolMap ss;
if (!janet_checktype(entry, JANET_TUPLE)) {
janet_asm_error(&a, "expected tuple");
}
tup = janet_unwrap_tuple(entry);
if (janet_keyeq(tup[0], "upvalue")) {
ss.birth_pc = UINT32_MAX;
} else if (!janet_checkint(tup[0])) {
janet_asm_error(&a, "expected integer");
} else {
ss.birth_pc = janet_unwrap_integer(tup[0]);
}
if (!janet_checkint(tup[1])) {
janet_asm_error(&a, "expected integer");
}
if (!janet_checkint(tup[2])) {
janet_asm_error(&a, "expected integer");
}
if (!janet_checktype(tup[3], JANET_SYMBOL)) {
janet_asm_error(&a, "expected symbol");
}
ss.death_pc = janet_unwrap_integer(tup[1]);
ss.slot_index = janet_unwrap_integer(tup[2]);
ss.symbol = janet_unwrap_symbol(tup[3]);
def->symbolmap[i] = ss;
}
}
if (def->symbolmap_length) def->flags |= JANET_FUNCDEF_FLAG_HASSYMBOLMAP;
/* Set environments */
def->environments =
janet_realloc(def->environments, def->environments_length * sizeof(int32_t));
if (NULL == def->environments) {
x = janet_get1(s, janet_ckeywordv("environments"));
if (janet_indexed_view(x, &arr, &count)) {
def->environments_length = count;
if (def->environments_length) {
def->environments = janet_realloc(def->environments, def->environments_length * sizeof(int32_t));
}
for (int32_t i = 0; i < count; i++) {
if (!janet_checkint(arr[i])) {
janet_asm_error(&a, "expected integer");
}
def->environments[i] = janet_unwrap_integer(arr[i]);
}
}
if (def->environments_length && NULL == def->environments) {
JANET_OUT_OF_MEMORY;
}
@@ -865,6 +926,29 @@ static Janet janet_disasm_slotcount(JanetFuncDef *def) {
return janet_wrap_integer(def->slotcount);
}
static Janet janet_disasm_symbolslots(JanetFuncDef *def) {
if (def->symbolmap == NULL) {
return janet_wrap_nil();
}
JanetArray *symbolslots = janet_array(def->symbolmap_length);
Janet upvaluekw = janet_ckeywordv("upvalue");
for (int32_t i = 0; i < def->symbolmap_length; i++) {
JanetSymbolMap ss = def->symbolmap[i];
Janet *t = janet_tuple_begin(4);
if (ss.birth_pc == UINT32_MAX) {
t[0] = upvaluekw;
} else {
t[0] = janet_wrap_integer(ss.birth_pc);
}
t[1] = janet_wrap_integer(ss.death_pc);
t[2] = janet_wrap_integer(ss.slot_index);
t[3] = janet_wrap_symbol(ss.symbol);
symbolslots->data[i] = janet_wrap_tuple(janet_tuple_end(t));
}
symbolslots->count = def->symbolmap_length;
return janet_wrap_array(symbolslots);
}
static Janet janet_disasm_bytecode(JanetFuncDef *def) {
JanetArray *bcode = janet_array(def->bytecode_length);
for (int32_t i = 0; i < def->bytecode_length; i++) {
@@ -944,6 +1028,7 @@ Janet janet_disasm(JanetFuncDef *def) {
janet_table_put(ret, janet_ckeywordv("structarg"), janet_disasm_structarg(def));
janet_table_put(ret, janet_ckeywordv("name"), janet_disasm_name(def));
janet_table_put(ret, janet_ckeywordv("slotcount"), janet_disasm_slotcount(def));
janet_table_put(ret, janet_ckeywordv("symbolmap"), janet_disasm_symbolslots(def));
janet_table_put(ret, janet_ckeywordv("constants"), janet_disasm_constants(def));
janet_table_put(ret, janet_ckeywordv("sourcemap"), janet_disasm_sourcemap(def));
janet_table_put(ret, janet_ckeywordv("environments"), janet_disasm_environments(def));
@@ -961,7 +1046,7 @@ JANET_CORE_FN(cfun_asm,
JanetAssembleResult res;
res = janet_asm(argv[0], 0);
if (res.status != JANET_ASSEMBLE_OK) {
janet_panics(res.error);
janet_panics(res.error ? res.error : janet_cstring("invalid assembly"));
}
return janet_wrap_function(janet_thunk(res.funcdef));
}
@@ -980,6 +1065,7 @@ JANET_CORE_FN(cfun_disasm,
"* :source - name of source file that this function was compiled from.\n"
"* :name - name of function.\n"
"* :slotcount - how many virtual registers, or slots, this function uses. Corresponds to stack space used by function.\n"
"* :symbolmap - all symbols and their slots.\n"
"* :constants - an array of constants referenced by this function.\n"
"* :sourcemap - a mapping of each bytecode instruction to a line and column in the source file.\n"
"* :environments - an internal mapping of which enclosing functions are referenced for bindings.\n"

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -28,8 +28,15 @@
#include "state.h"
#endif
/* Allow for managed buffers that cannot realloc/free their backing memory */
static void janet_buffer_can_realloc(JanetBuffer *buffer) {
if (buffer->gc.flags & JANET_BUFFER_FLAG_NO_REALLOC) {
janet_panic("buffer cannot reallocate foreign memory");
}
}
/* Initialize a buffer */
JanetBuffer *janet_buffer_init(JanetBuffer *buffer, int32_t capacity) {
static JanetBuffer *janet_buffer_init_impl(JanetBuffer *buffer, int32_t capacity) {
uint8_t *data = NULL;
if (capacity < 4) capacity = 4;
janet_gcpressure(capacity);
@@ -43,15 +50,37 @@ JanetBuffer *janet_buffer_init(JanetBuffer *buffer, int32_t capacity) {
return buffer;
}
/* Initialize a buffer */
JanetBuffer *janet_buffer_init(JanetBuffer *buffer, int32_t capacity) {
janet_buffer_init_impl(buffer, capacity);
buffer->gc.data.next = NULL;
buffer->gc.flags = JANET_MEM_DISABLED;
return buffer;
}
/* Initialize an unmanaged buffer */
JanetBuffer *janet_pointer_buffer_unsafe(void *memory, int32_t capacity, int32_t count) {
if (count < 0) janet_panic("count < 0");
if (capacity < count) janet_panic("capacity < count");
JanetBuffer *buffer = janet_gcalloc(JANET_MEMORY_BUFFER, sizeof(JanetBuffer));
buffer->gc.flags |= JANET_BUFFER_FLAG_NO_REALLOC;
buffer->capacity = capacity;
buffer->count = count;
buffer->data = (uint8_t *) memory;
return buffer;
}
/* Deinitialize a buffer (free data memory) */
void janet_buffer_deinit(JanetBuffer *buffer) {
janet_free(buffer->data);
if (!(buffer->gc.flags & JANET_BUFFER_FLAG_NO_REALLOC)) {
janet_free(buffer->data);
}
}
/* Initialize a buffer */
JanetBuffer *janet_buffer(int32_t capacity) {
JanetBuffer *buffer = janet_gcalloc(JANET_MEMORY_BUFFER, sizeof(JanetBuffer));
return janet_buffer_init(buffer, capacity);
return janet_buffer_init_impl(buffer, capacity);
}
/* Ensure that the buffer has enough internal capacity */
@@ -59,6 +88,7 @@ void janet_buffer_ensure(JanetBuffer *buffer, int32_t capacity, int32_t growth)
uint8_t *new_data;
uint8_t *old = buffer->data;
if (capacity <= buffer->capacity) return;
janet_buffer_can_realloc(buffer);
int64_t big_capacity = ((int64_t) capacity) * growth;
capacity = big_capacity > INT32_MAX ? INT32_MAX : (int32_t) big_capacity;
janet_gcpressure(capacity - buffer->capacity);
@@ -91,6 +121,7 @@ void janet_buffer_extra(JanetBuffer *buffer, int32_t n) {
}
int32_t new_size = buffer->count + n;
if (new_size > buffer->capacity) {
janet_buffer_can_realloc(buffer);
int32_t new_capacity = (new_size > (INT32_MAX / 2)) ? INT32_MAX : (new_size * 2);
uint8_t *new_data = janet_realloc(buffer->data, new_capacity * sizeof(uint8_t));
janet_gcpressure(new_capacity - buffer->capacity);
@@ -212,6 +243,7 @@ JANET_CORE_FN(cfun_buffer_trim,
"modified buffer.") {
janet_fixarity(argc, 1);
JanetBuffer *buffer = janet_getbuffer(argv, 0);
janet_buffer_can_realloc(buffer);
if (buffer->count < buffer->capacity) {
int32_t newcap = buffer->count > 4 ? buffer->count : 4;
uint8_t *newData = janet_realloc(buffer->data, newcap);
@@ -275,17 +307,8 @@ JANET_CORE_FN(cfun_buffer_chars,
return argv[0];
}
JANET_CORE_FN(cfun_buffer_push,
"(buffer/push buffer & xs)",
"Push both individual bytes and byte sequences to a buffer. For each x in xs, "
"push the byte if x is an integer, otherwise push the bytesequence to the buffer. "
"Thus, this function behaves like both `buffer/push-string` and `buffer/push-byte`. "
"Returns the modified buffer. "
"Will throw an error if the buffer overflows.") {
int32_t i;
janet_arity(argc, 1, -1);
JanetBuffer *buffer = janet_getbuffer(argv, 0);
for (i = 1; i < argc; i++) {
static void buffer_push_impl(JanetBuffer *buffer, Janet *argv, int32_t argc_offset, int32_t argc) {
for (int32_t i = argc_offset; i < argc; i++) {
if (janet_checktype(argv[i], JANET_NUMBER)) {
janet_buffer_push_u8(buffer, (uint8_t)(janet_getinteger(argv, i) & 0xFF));
} else {
@@ -297,9 +320,39 @@ JANET_CORE_FN(cfun_buffer_push,
janet_buffer_push_bytes(buffer, view.bytes, view.len);
}
}
}
JANET_CORE_FN(cfun_buffer_push_at,
"(buffer/push-at buffer index & xs)",
"Same as buffer/push, but copies the new data into the buffer "
" at index `index`.") {
janet_arity(argc, 2, -1);
JanetBuffer *buffer = janet_getbuffer(argv, 0);
int32_t index = janet_getinteger(argv, 1);
int32_t old_count = buffer->count;
if (index < 0 || index > old_count) {
janet_panicf("index out of range [0, %d)", old_count);
}
buffer->count = index;
buffer_push_impl(buffer, argv, 2, argc);
if (buffer->count < old_count) {
buffer->count = old_count;
}
return argv[0];
}
JANET_CORE_FN(cfun_buffer_push,
"(buffer/push buffer & xs)",
"Push both individual bytes and byte sequences to a buffer. For each x in xs, "
"push the byte if x is an integer, otherwise push the bytesequence to the buffer. "
"Thus, this function behaves like both `buffer/push-string` and `buffer/push-byte`. "
"Returns the modified buffer. "
"Will throw an error if the buffer overflows.") {
janet_arity(argc, 1, -1);
JanetBuffer *buffer = janet_getbuffer(argv, 0);
buffer_push_impl(buffer, argv, 1, argc);
return argv[0];
}
JANET_CORE_FN(cfun_buffer_clear,
"(buffer/clear buffer)",
@@ -442,7 +495,7 @@ JANET_CORE_FN(cfun_buffer_blit,
JANET_CORE_FN(cfun_buffer_format,
"(buffer/format buffer format & args)",
"Snprintf like functionality for printing values into a buffer. Returns "
" the modified buffer.") {
"the modified buffer.") {
janet_arity(argc, 2, -1);
JanetBuffer *buffer = janet_getbuffer(argv, 0);
const char *strfrmt = (const char *) janet_getstring(argv, 1);
@@ -460,6 +513,7 @@ void janet_lib_buffer(JanetTable *env) {
JANET_CORE_REG("buffer/push-word", cfun_buffer_word),
JANET_CORE_REG("buffer/push-string", cfun_buffer_chars),
JANET_CORE_REG("buffer/push", cfun_buffer_push),
JANET_CORE_REG("buffer/push-at", cfun_buffer_push_at),
JANET_CORE_REG("buffer/popn", cfun_buffer_popn),
JANET_CORE_REG("buffer/clear", cfun_buffer_clear),
JANET_CORE_REG("buffer/slice", cfun_buffer_slice),

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -25,6 +25,7 @@
#include <janet.h>
#include "gc.h"
#include "util.h"
#include "regalloc.h"
#endif
/* Look up table for instructions */
@@ -106,6 +107,289 @@ enum JanetInstructionType janet_instructions[JOP_INSTRUCTION_COUNT] = {
JINT_SSS /* JOP_CANCEL, */
};
/* Remove all noops while preserving jumps and debugging information.
* Useful as part of a filtering compiler pass. */
void janet_bytecode_remove_noops(JanetFuncDef *def) {
/* Get an instruction rewrite map so we can rewrite jumps */
uint32_t *pc_map = janet_smalloc(sizeof(uint32_t) * (1 + def->bytecode_length));
uint32_t new_bytecode_length = 0;
for (int32_t i = 0; i < def->bytecode_length; i++) {
uint32_t instr = def->bytecode[i];
uint32_t opcode = instr & 0x7F;
pc_map[i] = new_bytecode_length;
if (opcode != JOP_NOOP) {
new_bytecode_length++;
}
}
pc_map[def->bytecode_length] = new_bytecode_length;
/* Linear scan rewrite bytecode and sourcemap. Also fix jumps. */
int32_t j = 0;
for (int32_t i = 0; i < def->bytecode_length; i++) {
uint32_t instr = def->bytecode[i];
uint32_t opcode = instr & 0x7F;
int32_t old_jump_target = 0;
int32_t new_jump_target = 0;
switch (opcode) {
case JOP_NOOP:
continue;
case JOP_JUMP:
/* relative pc is in DS field of instruction */
old_jump_target = i + (((int32_t)instr) >> 8);
new_jump_target = pc_map[old_jump_target];
instr += (new_jump_target - old_jump_target + (i - j)) << 8;
break;
case JOP_JUMP_IF:
case JOP_JUMP_IF_NIL:
case JOP_JUMP_IF_NOT:
case JOP_JUMP_IF_NOT_NIL:
/* relative pc is in ES field of instruction */
old_jump_target = i + (((int32_t)instr) >> 16);
new_jump_target = pc_map[old_jump_target];
instr += (new_jump_target - old_jump_target + (i - j)) << 16;
break;
default:
break;
}
def->bytecode[j] = instr;
if (def->sourcemap != NULL) {
def->sourcemap[j] = def->sourcemap[i];
}
j++;
}
/* Rewrite symbolmap */
for (int32_t i = 0; i < def->symbolmap_length; i++) {
JanetSymbolMap *sm = def->symbolmap + i;
/* Don't rewrite upvalue mappings */
if (sm->birth_pc < UINT32_MAX) {
sm->birth_pc = pc_map[sm->birth_pc];
sm->death_pc = pc_map[sm->death_pc];
}
}
def->bytecode_length = new_bytecode_length;
def->bytecode = janet_realloc(def->bytecode, def->bytecode_length * sizeof(uint32_t));
janet_sfree(pc_map);
}
/* Remove redundant loads, moves and other instructions if possible and convert them to
* noops. Input is assumed valid bytecode. */
void janet_bytecode_movopt(JanetFuncDef *def) {
JanetcRegisterAllocator ra;
int recur = 1;
/* Iterate this until no more instructions can be removed. */
while (recur) {
janetc_regalloc_init(&ra);
/* Look for slots that have writes but no reads (and aren't in the closure bitset). */
if (def->closure_bitset != NULL) {
for (int32_t i = 0; i < def->slotcount; i++) {
int32_t index = i >> 5;
uint32_t mask = 1U << (((uint32_t) i) & 31);
if (def->closure_bitset[index] & mask) {
janetc_regalloc_touch(&ra, i);
}
}
}
#define AA ((instr >> 8) & 0xFF)
#define BB ((instr >> 16) & 0xFF)
#define CC (instr >> 24)
#define DD (instr >> 8)
#define EE (instr >> 16)
/* Check reads and writes */
for (int32_t i = 0; i < def->bytecode_length; i++) {
uint32_t instr = def->bytecode[i];
switch (instr & 0x7F) {
/* Group instructions my how they read from slots */
/* No reads or writes */
default:
janet_assert(0, "unhandled instruction");
case JOP_JUMP:
case JOP_NOOP:
case JOP_RETURN_NIL:
/* Write A */
case JOP_LOAD_INTEGER:
case JOP_LOAD_CONSTANT:
case JOP_LOAD_UPVALUE:
case JOP_CLOSURE:
/* Write D */
case JOP_LOAD_NIL:
case JOP_LOAD_TRUE:
case JOP_LOAD_FALSE:
case JOP_LOAD_SELF:
case JOP_MAKE_ARRAY:
case JOP_MAKE_BUFFER:
case JOP_MAKE_STRING:
case JOP_MAKE_STRUCT:
case JOP_MAKE_TABLE:
case JOP_MAKE_TUPLE:
case JOP_MAKE_BRACKET_TUPLE:
break;
/* Read A */
case JOP_ERROR:
case JOP_TYPECHECK:
case JOP_JUMP_IF:
case JOP_JUMP_IF_NOT:
case JOP_JUMP_IF_NIL:
case JOP_JUMP_IF_NOT_NIL:
case JOP_SET_UPVALUE:
/* Write E, Read A */
case JOP_MOVE_FAR:
janetc_regalloc_touch(&ra, AA);
break;
/* Read B */
case JOP_SIGNAL:
/* Write A, Read B */
case JOP_ADD_IMMEDIATE:
case JOP_MULTIPLY_IMMEDIATE:
case JOP_DIVIDE_IMMEDIATE:
case JOP_SHIFT_LEFT_IMMEDIATE:
case JOP_SHIFT_RIGHT_IMMEDIATE:
case JOP_SHIFT_RIGHT_UNSIGNED_IMMEDIATE:
case JOP_GREATER_THAN_IMMEDIATE:
case JOP_LESS_THAN_IMMEDIATE:
case JOP_EQUALS_IMMEDIATE:
case JOP_NOT_EQUALS_IMMEDIATE:
case JOP_GET_INDEX:
janetc_regalloc_touch(&ra, BB);
break;
/* Read D */
case JOP_RETURN:
case JOP_PUSH:
case JOP_PUSH_ARRAY:
case JOP_TAILCALL:
janetc_regalloc_touch(&ra, DD);
break;
/* Write A, Read E */
case JOP_MOVE_NEAR:
case JOP_LENGTH:
case JOP_BNOT:
case JOP_CALL:
janetc_regalloc_touch(&ra, EE);
break;
/* Read A, B */
case JOP_PUT_INDEX:
janetc_regalloc_touch(&ra, AA);
janetc_regalloc_touch(&ra, BB);
break;
/* Read A, E */
case JOP_PUSH_2:
janetc_regalloc_touch(&ra, AA);
janetc_regalloc_touch(&ra, EE);
break;
/* Read B, C */
case JOP_PROPAGATE:
/* Write A, Read B and C */
case JOP_BAND:
case JOP_BOR:
case JOP_BXOR:
case JOP_ADD:
case JOP_SUBTRACT:
case JOP_MULTIPLY:
case JOP_DIVIDE:
case JOP_MODULO:
case JOP_REMAINDER:
case JOP_SHIFT_LEFT:
case JOP_SHIFT_RIGHT:
case JOP_SHIFT_RIGHT_UNSIGNED:
case JOP_GREATER_THAN:
case JOP_LESS_THAN:
case JOP_EQUALS:
case JOP_COMPARE:
case JOP_IN:
case JOP_GET:
case JOP_GREATER_THAN_EQUAL:
case JOP_LESS_THAN_EQUAL:
case JOP_NOT_EQUALS:
case JOP_CANCEL:
case JOP_RESUME:
case JOP_NEXT:
janetc_regalloc_touch(&ra, BB);
janetc_regalloc_touch(&ra, CC);
break;
/* Read A, B, C */
case JOP_PUT:
case JOP_PUSH_3:
janetc_regalloc_touch(&ra, AA);
janetc_regalloc_touch(&ra, BB);
janetc_regalloc_touch(&ra, CC);
break;
}
}
/* Iterate and set noops on instructions that make writes that no one ever reads.
* Only set noops for instructions with no side effects - moves, loads, etc. that can't
* raise errors (outside of systemic errors like oom or stack overflow). */
recur = 0;
for (int32_t i = 0; i < def->bytecode_length; i++) {
uint32_t instr = def->bytecode[i];
switch (instr & 0x7F) {
default:
break;
/* Write D */
case JOP_LOAD_NIL:
case JOP_LOAD_TRUE:
case JOP_LOAD_FALSE:
case JOP_LOAD_SELF:
case JOP_MAKE_ARRAY:
case JOP_MAKE_TUPLE:
case JOP_MAKE_BRACKET_TUPLE: {
if (!janetc_regalloc_check(&ra, DD)) {
def->bytecode[i] = JOP_NOOP;
recur = 1;
}
}
break;
/* Write E, Read A */
case JOP_MOVE_FAR: {
if (!janetc_regalloc_check(&ra, EE)) {
def->bytecode[i] = JOP_NOOP;
recur = 1;
}
}
break;
/* Write A, Read E */
case JOP_MOVE_NEAR:
/* Write A, Read B */
case JOP_GET_INDEX:
/* Write A */
case JOP_LOAD_INTEGER:
case JOP_LOAD_CONSTANT:
case JOP_LOAD_UPVALUE:
case JOP_CLOSURE: {
if (!janetc_regalloc_check(&ra, AA)) {
def->bytecode[i] = JOP_NOOP;
recur = 1;
}
}
break;
}
}
janetc_regalloc_deinit(&ra);
#undef AA
#undef BB
#undef CC
#undef DD
#undef EE
}
}
/* Verify some bytecode */
int janet_verify(JanetFuncDef *def) {
int vargs = !!(def->flags & JANET_FUNCDEF_FLAG_VARARG);
@@ -218,6 +502,7 @@ JanetFuncDef *janet_funcdef_alloc(void) {
def->closure_bitset = NULL;
def->flags = 0;
def->slotcount = 0;
def->symbolmap = NULL;
def->arity = 0;
def->min_arity = 0;
def->max_arity = INT32_MAX;
@@ -229,6 +514,7 @@ JanetFuncDef *janet_funcdef_alloc(void) {
def->constants_length = 0;
def->bytecode_length = 0;
def->environments_length = 0;
def->symbolmap_length = 0;
return def;
}

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -209,14 +209,28 @@ const char *janet_optcstring(const Janet *argv, int32_t argc, int32_t n, const c
#undef DEFINE_OPTLEN
const char *janet_getcstring(const Janet *argv, int32_t n) {
const uint8_t *jstr = janet_getstring(argv, n);
const char *cstr = (const char *)jstr;
if (strlen(cstr) != (size_t) janet_string_length(jstr)) {
janet_panic("string contains embedded 0s");
if (!janet_checktype(argv[n], JANET_STRING)) {
janet_panic_type(argv[n], n, JANET_TFLAG_STRING);
}
return janet_getcbytes(argv, n);
}
const char *janet_getcbytes(const Janet *argv, int32_t n) {
JanetByteView view = janet_getbytes(argv, n);
const char *cstr = (const char *)view.bytes;
if (strlen(cstr) != (size_t) view.len) {
janet_panic("bytes contain embedded 0s");
}
return cstr;
}
const char *janet_optcbytes(const Janet *argv, int32_t argc, int32_t n, const char *dflt) {
if (n >= argc || janet_checktype(argv[n], JANET_NIL)) {
return dflt;
}
return janet_getcbytes(argv, n);
}
int32_t janet_getnat(const Janet *argv, int32_t n) {
Janet x = argv[n];
if (!janet_checkint(x)) goto bad;
@@ -259,6 +273,14 @@ int32_t janet_getinteger(const Janet *argv, int32_t n) {
return janet_unwrap_integer(x);
}
uint32_t janet_getuinteger(const Janet *argv, int32_t n) {
Janet x = argv[n];
if (!janet_checkuint(x)) {
janet_panicf("bad slot #%d, expected 32 bit signed integer, got %v", n, x);
}
return janet_unwrap_integer(x);
}
int64_t janet_getinteger64(const Janet *argv, int32_t n) {
#ifdef JANET_INT_TYPES
return janet_unwrap_s64(argv[n]);
@@ -276,7 +298,7 @@ uint64_t janet_getuinteger64(const Janet *argv, int32_t n) {
return janet_unwrap_u64(argv[n]);
#else
Janet x = argv[n];
if (!janet_checkint64(x)) {
if (!janet_checkuint64(x)) {
janet_panicf("bad slot #%d, expected 64 bit unsigned integer, got %v", n, x);
}
return (uint64_t) janet_unwrap_number(x);

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -93,10 +93,14 @@ 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) {
SymPair sp;
int32_t cnt = janet_v_count(c->buffer);
sp.sym = sym;
sp.sym2 = sym;
sp.slot = s;
sp.keep = 0;
sp.slot.flags |= JANET_SLOT_NAMED;
sp.birth_pc = cnt ? cnt - 1 : 0;
sp.death_pc = UINT32_MAX;
janet_v_push(c->scope->syms, sp);
}
@@ -159,21 +163,27 @@ void janetc_popscope(JanetCompiler *c) {
if (oldscope->flags & JANET_SCOPE_CLOSURE) {
newscope->flags |= JANET_SCOPE_CLOSURE;
}
if (newscope->ra.max < oldscope->ra.max)
if (newscope->ra.max < oldscope->ra.max) {
newscope->ra.max = oldscope->ra.max;
/* Keep upvalue slots */
for (int32_t i = 0; i < janet_v_count(oldscope->syms); i++) {
SymPair pair = oldscope->syms[i];
if (pair.keep) {
/* The variable should not be lexically accessible */
pair.sym = NULL;
janet_v_push(newscope->syms, pair);
janetc_regalloc_touch(&newscope->ra, pair.slot.index);
}
}
/* Keep upvalue slots and symbols for debugging. */
for (int32_t i = 0; i < janet_v_count(oldscope->syms); i++) {
SymPair pair = oldscope->syms[i];
/* The variable should not be lexically accessible */
pair.sym = NULL;
if (pair.death_pc == UINT32_MAX) {
pair.death_pc = (uint32_t) janet_v_count(c->buffer);
}
if (pair.keep) {
/* The variable should also not be included in the locals */
pair.sym2 = NULL;
janetc_regalloc_touch(&newscope->ra, pair.slot.index);
}
janet_v_push(newscope->syms, pair);
}
}
/* Free the old scope */
janet_v_free(oldscope->consts);
janet_v_free(oldscope->syms);
@@ -334,6 +344,7 @@ found:
}
/* non-local scope needs to expose its environment */
JanetScope *original_scope = scope;
pair->keep = 1;
while (scope && !(scope->flags & JANET_SCOPE_FUNCTION))
scope = scope->parent;
@@ -355,7 +366,7 @@ found:
/* Check if scope already has env. If so, break */
len = janet_v_count(scope->envs);
for (j = 0; j < len; j++) {
if (scope->envs[j] == envindex) {
if (scope->envs[j].envindex == envindex) {
scopefound = 1;
envindex = j;
break;
@@ -364,7 +375,10 @@ found:
/* Add the environment if it is not already referenced */
if (!scopefound) {
len = janet_v_count(scope->envs);
janet_v_push(scope->envs, envindex);
JanetEnvRef ref;
ref.envindex = envindex;
ref.scope = original_scope;
janet_v_push(scope->envs, ref);
envindex = len;
}
}
@@ -408,6 +422,7 @@ JanetSlot *janetc_toslots(JanetCompiler *c, const Janet *vals, int32_t len) {
int32_t i;
JanetSlot *ret = NULL;
JanetFopts subopts = janetc_fopts_default(c);
subopts.flags |= JANET_FOPTS_ACCEPT_SPLICE;
for (i = 0; i < len; i++) {
janet_v_push(ret, janetc_value(subopts, vals[i]));
}
@@ -418,6 +433,7 @@ JanetSlot *janetc_toslots(JanetCompiler *c, const Janet *vals, int32_t len) {
JanetSlot *janetc_toslotskv(JanetCompiler *c, Janet ds) {
JanetSlot *ret = NULL;
JanetFopts subopts = janetc_fopts_default(c);
subopts.flags |= JANET_FOPTS_ACCEPT_SPLICE;
const JanetKV *kvs = NULL;
int32_t cap = 0, len = 0;
janet_dictionary_view(ds, &kvs, &len, &cap);
@@ -730,12 +746,14 @@ static int macroexpand1(
int lock = janet_gclock();
Janet mf_kw = janet_ckeywordv("macro-form");
janet_table_put(c->env, mf_kw, x);
Janet ml_kw = janet_ckeywordv("macro-lints");
if (c->lints) {
janet_table_put(c->env, ml_kw, janet_wrap_array(c->lints));
}
Janet tempOut;
JanetSignal status = janet_continue(fiberp, janet_wrap_nil(), &tempOut);
janet_table_put(c->env, mf_kw, janet_wrap_nil());
if (c->lints) {
janet_table_put(c->env, janet_ckeywordv("macro-lints"), janet_wrap_array(c->lints));
}
janet_table_put(c->env, ml_kw, janet_wrap_nil());
janet_gcunlock(lock);
if (status != JANET_SIGNAL_OK) {
const uint8_t *es = janet_formatc("(macro) %V", tempOut);
@@ -868,7 +886,10 @@ JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c) {
/* Copy envs */
def->environments_length = janet_v_count(scope->envs);
def->environments = janet_v_flatten(scope->envs);
def->environments = janet_malloc(sizeof(int32_t) * def->environments_length);
for (int32_t i = 0; i < def->environments_length; i++) {
def->environments[i] = scope->envs[i].envindex;
}
def->constants_length = janet_v_count(scope->consts);
def->constants = janet_v_flatten(scope->consts);
@@ -923,9 +944,66 @@ JanetFuncDef *janetc_pop_funcdef(JanetCompiler *c) {
def->closure_bitset = chunks;
}
/* Capture symbol to local mapping */
JanetSymbolMap *locals = NULL;
/* Symbol -> upvalue mapping */
JanetScope *top = c->scope;
while (top->parent) top = top->parent;
for (JanetScope *s = top; s != NULL; s = s->child) {
for (int32_t j = 0; j < janet_v_count(scope->envs); j++) {
JanetEnvRef ref = scope->envs[j];
JanetScope *upscope = ref.scope;
if (upscope != s) continue;
for (int32_t i = 0; i < janet_v_count(upscope->syms); i++) {
SymPair pair = upscope->syms[i];
if (pair.sym2) {
JanetSymbolMap jsm;
jsm.birth_pc = UINT32_MAX;
jsm.death_pc = j;
jsm.slot_index = pair.slot.index;
jsm.symbol = pair.sym2;
janet_v_push(locals, jsm);
}
}
}
}
/* Symbol -> slot mapping */
for (int32_t i = 0; i < janet_v_count(scope->syms); i++) {
SymPair pair = scope->syms[i];
if (pair.sym2) {
JanetSymbolMap jsm;
if (pair.death_pc == UINT32_MAX) {
jsm.death_pc = def->bytecode_length;
} else {
jsm.death_pc = pair.death_pc - scope->bytecode_start;
}
/* Handle birth_pc == 0 correctly */
if ((uint32_t) scope->bytecode_start > pair.birth_pc) {
jsm.birth_pc = 0;
} else {
jsm.birth_pc = pair.birth_pc - scope->bytecode_start;
}
janet_assert(jsm.birth_pc <= jsm.death_pc, "birth pc after death pc");
janet_assert(jsm.birth_pc < (uint32_t) def->bytecode_length, "bad birth pc");
janet_assert(jsm.death_pc <= (uint32_t) def->bytecode_length, "bad death pc");
jsm.slot_index = pair.slot.index;
jsm.symbol = pair.sym2;
janet_v_push(locals, jsm);
}
}
def->symbolmap_length = janet_v_count(locals);
def->symbolmap = janet_v_flatten(locals);
if (def->symbolmap_length) def->flags |= JANET_FUNCDEF_FLAG_HASSYMBOLMAP;
/* Pop the scope */
janetc_popscope(c);
/* Do basic optimization */
janet_bytecode_movopt(def);
janet_bytecode_remove_noops(def);
return def;
}
@@ -1005,7 +1083,8 @@ JANET_CORE_FN(cfun_compile,
"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_arity(argc, 1, 4);
JanetTable *env = argc > 1 ? janet_gettable(argv, 1) : janet_vm.fiber->env;
JanetTable *env = (argc > 1 && !janet_checktype(argv[1], JANET_NIL))
? janet_gettable(argv, 1) : janet_vm.fiber->env;
if (NULL == env) {
env = janet_table(0);
janet_vm.fiber->env = env;
@@ -1017,11 +1096,12 @@ JANET_CORE_FN(cfun_compile,
source = janet_unwrap_string(x);
} else if (janet_checktype(x, JANET_KEYWORD)) {
source = janet_unwrap_keyword(x);
} else {
} else if (!janet_checktype(x, JANET_NIL)) {
janet_panic_type(x, 2, JANET_TFLAG_STRING | JANET_TFLAG_KEYWORD);
}
}
JanetArray *lints = (argc >= 4) ? janet_getarray(argv, 3) : NULL;
JanetArray *lints = (argc >= 4 && !janet_checktype(argv[3], JANET_NIL))
? janet_getarray(argv, 3) : NULL;
JanetCompileResult res = janet_compile_lint(argv[0], env, source, lints);
if (res.status == JANET_COMPILE_OK) {
return janet_wrap_function(janet_thunk(res.funcdef));

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -111,13 +111,21 @@ struct JanetSlot {
typedef struct SymPair {
JanetSlot slot;
const uint8_t *sym;
const uint8_t *sym2;
int keep;
uint32_t birth_pc;
uint32_t death_pc;
} SymPair;
typedef struct JanetEnvRef {
int32_t envindex;
JanetScope *scope;
} JanetEnvRef;
/* A lexical scope during compilation */
struct JanetScope {
/* For debugging */
/* For debugging the compiler */
const char *name;
/* Scopes are doubly linked list */
@@ -133,7 +141,7 @@ struct JanetScope {
/* FuncDefs */
JanetFuncDef **defs;
/* Regsiter allocator */
/* Register allocator */
JanetcRegisterAllocator ra;
/* Upvalue allocator */
@@ -142,7 +150,7 @@ struct JanetScope {
/* Referenced closure environments. The values at each index correspond
* to which index to get the environment from in the parent. The environment
* that corresponds to the direct parent's stack will always have value 0. */
int32_t *envs;
JanetEnvRef *envs;
int32_t bytecode_start;
int flags;
@@ -179,6 +187,7 @@ struct JanetCompiler {
#define JANET_FOPTS_TAIL 0x10000
#define JANET_FOPTS_HINT 0x20000
#define JANET_FOPTS_DROP 0x40000
#define JANET_FOPTS_ACCEPT_SPLICE 0x80000
/* Options for compiling a single form */
struct JanetFopts {
@@ -227,7 +236,7 @@ JanetSlot *janetc_toslots(JanetCompiler *c, const Janet *vals, int32_t len);
/* Get a bunch of slots for function arguments */
JanetSlot *janetc_toslotskv(JanetCompiler *c, Janet ds);
/* Push slots load via janetc_toslots. */
/* Push slots loaded via janetc_toslots. */
int32_t janetc_pushslots(JanetCompiler *c, JanetSlot *slots);
/* Free slots loaded via janetc_toslots */
@@ -258,4 +267,8 @@ JanetSlot janetc_cslot(Janet x);
/* Search for a symbol */
JanetSlot janetc_resolve(JanetCompiler *c, const uint8_t *sym);
/* Bytecode optimization */
void janet_bytecode_movopt(JanetFuncDef *def);
void janet_bytecode_remove_noops(JanetFuncDef *def);
#endif

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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 @@ extern size_t janet_core_image_size;
#endif
JanetModule janet_native(const char *name, const uint8_t **error) {
janet_sandbox_assert(JANET_SANDBOX_DYNAMIC_MODULES);
char *processed_name = get_processed_name(name);
Clib lib = load_clib(processed_name);
JanetModule init;
@@ -111,7 +112,10 @@ JANET_CORE_FN(janet_core_expand_path,
"This takes in a path (the argument to require) and a template string, "
"to expand the path to a path that can be "
"used for importing files. The replacements are as follows:\n\n"
"* :all: -- the value of path verbatim\n\n"
"* :all: -- the value of path verbatim.\n\n"
"* :@all: -- Same as :all:, but if `path` starts with the @ character,\n"
" the first path segment is replaced with a dynamic binding\n"
" `(dyn <first path segment as keyword>)`.\n\n"
"* :cur: -- the current file, or (dyn :current-file)\n\n"
"* :dir: -- the directory containing the current file\n\n"
"* :name: -- the name component of path, with extension if given\n\n"
@@ -157,6 +161,21 @@ JANET_CORE_FN(janet_core_expand_path,
if (strncmp(template + i, ":all:", 5) == 0) {
janet_buffer_push_cstring(out, input);
i += 4;
} else if (strncmp(template + i, ":@all:", 6) == 0) {
if (input[0] == '@') {
const char *p = input;
while (*p && !is_path_sep(*p)) p++;
size_t len = p - input - 1;
char *str = janet_smalloc(len + 1);
memcpy(str, input + 1, len);
str[len] = '\0';
janet_formatb(out, "%V", janet_dyn(str));
janet_sfree(str);
janet_buffer_push_cstring(out, p);
} else {
janet_buffer_push_cstring(out, input);
}
i += 5;
} else if (strncmp(template + i, ":cur:", 5) == 0) {
janet_buffer_push_bytes(out, (const uint8_t *)curdir, curlen);
i += 4;
@@ -439,7 +458,7 @@ JANET_CORE_FN(janet_core_getproto,
? janet_wrap_struct(janet_struct_proto(st))
: janet_wrap_nil();
}
janet_panicf("expected struct|table, got %v", argv[0]);
janet_panicf("expected struct or table, got %v", argv[0]);
}
JANET_CORE_FN(janet_core_struct,
@@ -632,6 +651,87 @@ JANET_CORE_FN(janet_core_signal,
janet_panicf("unknown signal %v", argv[0]);
}
JANET_CORE_FN(janet_core_memcmp,
"(memcmp a b &opt len offset-a offset-b)",
"Compare memory. Takes two byte sequences `a` and `b`, and "
"return 0 if they have identical contents, a negative integer if a is less than b, "
"and a positive integer if a is greater than b. Optionally take a length and offsets "
"to compare slices of the bytes sequences.") {
janet_arity(argc, 2, 5);
JanetByteView a = janet_getbytes(argv, 0);
JanetByteView b = janet_getbytes(argv, 1);
int32_t len = janet_optnat(argv, argc, 2, a.len < b.len ? a.len : b.len);
int32_t offset_a = janet_optnat(argv, argc, 3, 0);
int32_t offset_b = janet_optnat(argv, argc, 4, 0);
if (offset_a + len > a.len) janet_panicf("invalid offset-a: %d", offset_a);
if (offset_b + len > b.len) janet_panicf("invalid offset-b: %d", offset_b);
return janet_wrap_integer(memcmp(a.bytes + offset_a, b.bytes + offset_b, (size_t) len));
}
typedef struct SandboxOption {
const char *name;
uint32_t flag;
} SandboxOption;
static const SandboxOption sandbox_options[] = {
{"all", JANET_SANDBOX_ALL},
{"env", JANET_SANDBOX_ENV},
{"ffi", JANET_SANDBOX_FFI},
{"ffi-define", JANET_SANDBOX_FFI_DEFINE},
{"ffi-jit", JANET_SANDBOX_FFI_JIT},
{"ffi-use", JANET_SANDBOX_FFI_USE},
{"fs", JANET_SANDBOX_FS},
{"fs-read", JANET_SANDBOX_FS_READ},
{"fs-temp", JANET_SANDBOX_FS_TEMP},
{"fs-write", JANET_SANDBOX_FS_WRITE},
{"hrtime", JANET_SANDBOX_HRTIME},
{"modules", JANET_SANDBOX_DYNAMIC_MODULES},
{"net", JANET_SANDBOX_NET},
{"net-connect", JANET_SANDBOX_NET_CONNECT},
{"net-listen", JANET_SANDBOX_NET_LISTEN},
{"sandbox", JANET_SANDBOX_SANDBOX},
{"subprocess", JANET_SANDBOX_SUBPROCESS},
{NULL, 0}
};
JANET_CORE_FN(janet_core_sandbox,
"(sandbox & forbidden-capabilities)",
"Disable feature sets to prevent the interpreter from using certain system resources. "
"Once a feature is disabled, there is no way to re-enable it. Capabilities can be:\n\n"
"* :all - disallow all (except IO to stdout, stderr, and stdin)\n"
"* :env - disallow reading and write env variables\n"
"* :ffi - disallow FFI (recommended if disabling anything else)\n"
"* :ffi-define - disallow loading new FFI modules and binding new functions\n"
"* :ffi-jit - disallow calling `ffi/jitfn`\n"
"* :ffi-use - disallow using any previously bound FFI functions and memory-unsafe functions.\n"
"* :fs - disallow access to the file system\n"
"* :fs-read - disallow read access to the file system\n"
"* :fs-temp - disallow creating temporary files\n"
"* :fs-write - disallow write access to the file system\n"
"* :hrtime - disallow high-resolution timers\n"
"* :modules - disallow load dynamic modules (natives)\n"
"* :net - disallow network access\n"
"* :net-connect - disallow making outbound network connections\n"
"* :net-listen - disallow accepting inbound network connections\n"
"* :sandbox - disallow calling this function\n"
"* :subprocess - disallow running subprocesses") {
uint32_t flags = 0;
for (int32_t i = 0; i < argc; i++) {
JanetKeyword kw = janet_getkeyword(argv, i);
const SandboxOption *opt = sandbox_options;
while (opt->name != NULL) {
if (janet_cstrcmp(kw, opt->name) == 0) {
flags |= opt->flag;
break;
}
opt++;
}
if (opt->name == NULL) janet_panicf("unknown capability %v", argv[i]);
}
janet_sandbox(flags);
return janet_wrap_nil();
}
#ifdef JANET_BOOTSTRAP
/* Utility for inline assembly */
@@ -933,7 +1033,9 @@ static void janet_load_libs(JanetTable *env) {
JANET_CORE_REG("nat?", janet_core_check_nat),
JANET_CORE_REG("slice", janet_core_slice),
JANET_CORE_REG("signal", janet_core_signal),
JANET_CORE_REG("memcmp", janet_core_memcmp),
JANET_CORE_REG("getproto", janet_core_getproto),
JANET_CORE_REG("sandbox", janet_core_sandbox),
JANET_REG_END
};
janet_core_cfuns_ext(env, NULL, corelib_cfuns);

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -131,9 +131,9 @@ void janet_stacktrace_ext(JanetFiber *fiber, Janet err, const char *prefix) {
if (!wrote_error) {
JanetFiberStatus status = janet_fiber_status(fiber);
janet_eprintf("%s%s: %s\n",
prefix,
prefix ? prefix : "",
janet_status_names[status],
errstr);
errstr ? errstr : janet_status_names[status]);
wrote_error = 1;
}
@@ -314,6 +314,7 @@ static Janet doframe(JanetStackFrame *frame) {
if (frame->func && frame->pc) {
Janet *stack = (Janet *)frame + JANET_FRAME_SIZE;
JanetArray *slots;
janet_assert(def != NULL, "def != NULL");
off = (int32_t)(frame->pc - def->bytecode);
janet_table_put(t, janet_ckeywordv("pc"), janet_wrap_integer(off));
if (def->sourcemap) {
@@ -329,6 +330,27 @@ static Janet doframe(JanetStackFrame *frame) {
safe_memcpy(slots->data, stack, sizeof(Janet) * def->slotcount);
slots->count = def->slotcount;
janet_table_put(t, janet_ckeywordv("slots"), janet_wrap_array(slots));
/* Add local bindings */
if (def->symbolmap) {
JanetTable *local_bindings = janet_table(0);
for (int32_t i = def->symbolmap_length - 1; i >= 0; i--) {
JanetSymbolMap jsm = def->symbolmap[i];
Janet value = janet_wrap_nil();
uint32_t pc = (uint32_t)(frame->pc - def->bytecode);
if (jsm.birth_pc == UINT32_MAX) {
JanetFuncEnv *env = frame->func->envs[jsm.death_pc];
if (env->offset > 0) {
value = env->as.fiber->data[env->offset + jsm.slot_index];
} else {
value = env->as.values[jsm.slot_index];
}
} else if (pc >= jsm.birth_pc && pc < jsm.death_pc) {
value = stack[jsm.slot_index];
}
janet_table_put(local_bindings, janet_wrap_symbol(jsm.symbol), value);
}
janet_table_put(t, janet_ckeywordv("locals"), janet_wrap_table(local_bindings));
}
}
return janet_wrap_table(t);
}

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -20,7 +20,6 @@
* IN THE SOFTWARE.
*/
#ifndef JANET_AMALG
#include "features.h"
#include <janet.h>
@@ -172,6 +171,9 @@ static JanetTimestamp ts_now(void);
/* Get current timestamp + an interval (millisecond precision) */
static JanetTimestamp ts_delta(JanetTimestamp ts, double delta) {
if (isinf(delta)) {
return delta < 0 ? ts : INT64_MAX;
}
ts += (int64_t)round(delta * 1000);
return ts;
}
@@ -362,7 +364,6 @@ void janet_stream_close(JanetStream *stream) {
janet_stream_close_impl(stream, 0);
}
/* Called to clean up a stream */
static int janet_stream_gc(void *p, size_t s) {
(void) s;
@@ -400,7 +401,7 @@ static void janet_stream_marshal(void *p, JanetMarshalContext *ctx) {
}
janet_marshal_abstract(ctx, p);
janet_marshal_int(ctx, (int32_t) s->flags);
janet_marshal_int64(ctx, (intptr_t) s->methods);
janet_marshal_ptr(ctx, s->methods);
#ifdef JANET_WINDOWS
/* TODO - ref counting to avoid situation where a handle is closed or GCed
* while in transit, and it's value gets reused. DuplicateHandle does not work
@@ -437,7 +438,7 @@ static void *janet_stream_unmarshal(JanetMarshalContext *ctx) {
p->_mask = 0;
p->state = NULL;
p->flags = (uint32_t) janet_unmarshal_int(ctx);
p->methods = (void *) janet_unmarshal_int64(ctx);
p->methods = janet_unmarshal_ptr(ctx);
#ifdef JANET_WINDOWS
p->handle = (JanetHandle) janet_unmarshal_int64(ctx);
#else
@@ -469,8 +470,12 @@ const JanetAbstractType janet_stream_type = {
/* Register a fiber to resume with value */
void janet_schedule_signal(JanetFiber *fiber, Janet value, JanetSignal sig) {
if (fiber->gc.flags & JANET_FIBER_EV_FLAG_CANCELED) return;
fiber->gc.flags |= JANET_FIBER_FLAG_ROOT;
if (!(fiber->gc.flags & JANET_FIBER_FLAG_ROOT)) {
Janet task_element = janet_wrap_fiber(fiber);
janet_table_put(&janet_vm.active_tasks, task_element, janet_wrap_true());
}
JanetTask t = { fiber, value, sig, ++fiber->sched_id };
fiber->gc.flags |= JANET_FIBER_FLAG_ROOT;
if (sig == JANET_SIGNAL_ERROR) fiber->gc.flags |= JANET_FIBER_EV_FLAG_CANCELED;
janet_q_push(&janet_vm.spawn, &t, sizeof(t));
}
@@ -556,7 +561,12 @@ void janet_ev_init_common(void) {
janet_vm.tq_count = 0;
janet_vm.tq_capacity = 0;
janet_table_init_raw(&janet_vm.threaded_abstracts, 0);
janet_table_init_raw(&janet_vm.active_tasks, 0);
janet_rng_seed(&janet_vm.ev_rng, 0);
#ifndef JANET_WINDOWS
pthread_attr_init(&janet_vm.new_thread_attr);
pthread_attr_setdetachstate(&janet_vm.new_thread_attr, PTHREAD_CREATE_DETACHED);
#endif
}
/* Common deinit code */
@@ -566,10 +576,15 @@ void janet_ev_deinit_common(void) {
janet_free(janet_vm.listeners);
janet_vm.listeners = NULL;
janet_table_deinit(&janet_vm.threaded_abstracts);
janet_table_deinit(&janet_vm.active_tasks);
#ifndef JANET_WINDOWS
pthread_attr_destroy(&janet_vm.new_thread_attr);
#endif
}
/* Short hand to yield to event loop */
/* Shorthand to yield to event loop */
void janet_await(void) {
/* Store the fiber in a gobal table */
janet_signalv(JANET_SIGNAL_EVENT, janet_wrap_nil());
}
@@ -655,19 +670,6 @@ static void janet_chan_init(JanetChannel *chan, int32_t limit, int threaded) {
janet_os_mutex_init((JanetOSMutex *) &chan->lock);
}
static void janet_chan_deinit(JanetChannel *chan) {
janet_q_deinit(&chan->read_pending);
janet_q_deinit(&chan->write_pending);
if (janet_chan_is_threaded(chan)) {
Janet item;
while (!janet_q_pop(&chan->items, &item, sizeof(item))) {
janet_chan_unpack(chan, &item, 1);
}
}
janet_q_deinit(&chan->items);
janet_os_mutex_deinit((JanetOSMutex *) &chan->lock);
}
static void janet_chan_lock(JanetChannel *chan) {
if (!janet_chan_is_threaded(chan)) return;
janet_os_mutex_lock((JanetOSMutex *) &chan->lock);
@@ -678,6 +680,25 @@ static void janet_chan_unlock(JanetChannel *chan) {
janet_os_mutex_unlock((JanetOSMutex *) &chan->lock);
}
static void janet_chan_deinit(JanetChannel *chan) {
if (janet_chan_is_threaded(chan)) {
Janet item;
janet_chan_lock(chan);
janet_q_deinit(&chan->read_pending);
janet_q_deinit(&chan->write_pending);
while (!janet_q_pop(&chan->items, &item, sizeof(item))) {
janet_chan_unpack(chan, &item, 1);
}
janet_q_deinit(&chan->items);
janet_chan_unlock(chan);
} else {
janet_q_deinit(&chan->read_pending);
janet_q_deinit(&chan->write_pending);
janet_q_deinit(&chan->items);
}
janet_os_mutex_deinit((JanetOSMutex *) &chan->lock);
}
/*
* Janet Channel abstract type
*/
@@ -754,6 +775,7 @@ static void janet_thread_chan_cb(JanetEVGenericMessage msg) {
int mode = msg.tag;
JanetChannel *channel = (JanetChannel *) msg.argp;
Janet x = msg.argj;
janet_chan_lock(channel);
if (fiber->sched_id == sched_id) {
if (mode == JANET_CP_MODE_CHOICE_READ) {
janet_assert(!janet_chan_unpack(channel, &x, 0), "packing error");
@@ -774,7 +796,6 @@ static void janet_thread_chan_cb(JanetEVGenericMessage msg) {
int is_read = (mode == JANET_CP_MODE_CHOICE_READ) || (mode == JANET_CP_MODE_READ);
if (is_read) {
JanetChannelPending reader;
janet_chan_lock(channel);
if (!janet_q_pop(&channel->read_pending, &reader, sizeof(reader))) {
JanetVM *vm = reader.thread;
JanetEVGenericMessage msg;
@@ -785,10 +806,8 @@ static void janet_thread_chan_cb(JanetEVGenericMessage msg) {
msg.argj = x;
janet_ev_post_event(vm, janet_thread_chan_cb, msg);
}
janet_chan_unlock(channel);
} else {
JanetChannelPending writer;
janet_chan_lock(channel);
if (!janet_q_pop(&channel->write_pending, &writer, sizeof(writer))) {
JanetVM *vm = writer.thread;
JanetEVGenericMessage msg;
@@ -799,21 +818,21 @@ static void janet_thread_chan_cb(JanetEVGenericMessage msg) {
msg.argj = janet_wrap_nil();
janet_ev_post_event(vm, janet_thread_chan_cb, msg);
}
janet_chan_unlock(channel);
}
}
janet_chan_unlock(channel);
}
/* Push a value to a channel, and return 1 if channel should block, zero otherwise.
* If the push would block, will add to the write_pending queue in the channel.
* Handles both threaded and unthreaded channels. */
static int janet_channel_push(JanetChannel *channel, Janet x, int mode) {
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);
}
janet_chan_lock(channel);
if (channel->closed) {
janet_chan_unlock(channel);
janet_panic("cannot write to closed channel");
@@ -874,12 +893,16 @@ static int janet_channel_push(JanetChannel *channel, Janet x, int mode) {
return 0;
}
static int janet_channel_push(JanetChannel *channel, Janet x, int mode) {
janet_chan_lock(channel);
return janet_channel_push_with_lock(channel, x, mode);
}
/* Pop from a channel - returns 1 if item was obtained, 0 otherwise. The item
* is returned by reference. If the pop would block, will add to the read_pending
* queue in the channel. */
static int janet_channel_pop(JanetChannel *channel, Janet *item, int is_choice) {
static int janet_channel_pop_with_lock(JanetChannel *channel, Janet *item, int is_choice) {
JanetChannelPending writer;
janet_chan_lock(channel);
if (channel->closed) {
janet_chan_unlock(channel);
*item = janet_wrap_nil();
@@ -924,6 +947,11 @@ static int janet_channel_pop(JanetChannel *channel, Janet *item, int is_choice)
return 1;
}
static int janet_channel_pop(JanetChannel *channel, Janet *item, int is_choice) {
janet_chan_lock(channel);
return janet_channel_pop_with_lock(channel, item, is_choice);
}
JanetChannel *janet_channel_unwrap(void *abstract) {
return abstract;
}
@@ -966,13 +994,32 @@ 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 tuple of the form [:give chan], [:take chan x], or [:close chan], where "
"a :give tuple is the result of a write and :take tuple is the result of a read. Each clause must be either a channel (for "
"a channel take operation) or a tuple [channel x] for a channel give operation. Operations are tried in order, such that the first "
"clauses will take precedence over later clauses. Both and give and take operations can return a [:close chan] tuple, which indicates that "
"the specified channel was closed while waiting, or that the channel was already closed.") {
"Block until the first of several channel operations occur. Returns a "
"tuple of the form [:give chan], [:take chan x], or [:close chan], "
"where a :give tuple is the result of a write and a :take tuple is the "
"result of a read. Each clause must be either a channel (for a channel "
"take operation) or a tuple [channel x] (for a channel give operation). "
"Operations are tried in order such that earlier clauses take "
"precedence over later clauses. Both give and take operations can "
"return a [:close chan] tuple, which indicates that the specified "
"channel was closed while waiting, or that the channel was already "
"closed.") {
janet_arity(argc, 1, -1);
int32_t len;
const Janet *data;
@@ -985,29 +1032,29 @@ 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_chan_unlock(chan);
janet_channel_push(chan, data[1], 1);
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_chan_unlock(chan);
janet_channel_pop(chan, &item, 1);
janet_channel_pop_with_lock(chan, &item, 1);
chan_unlock_args(argv, i);
return make_read_result(chan, item);
}
janet_chan_unlock(chan);
}
}
@@ -1016,12 +1063,12 @@ JANET_CORE_FN(cfun_channel_choice,
if (janet_indexed_view(argv[i], &data, &len) && len == 2) {
/* Write */
JanetChannel *chan = janet_getchannel(data, 0);
janet_channel_push(chan, data[1], 1);
janet_channel_push_with_lock(chan, data[1], 1);
} else {
/* Read */
Janet item;
JanetChannel *chan = janet_getchannel(argv, i);
janet_channel_pop(chan, &item, 1);
janet_channel_pop_with_lock(chan, &item, 1);
}
}
@@ -1122,9 +1169,9 @@ JANET_CORE_FN(cfun_channel_close,
janet_ev_post_event(vm, janet_thread_chan_cb, msg);
} else {
if (writer.mode == JANET_CP_MODE_CHOICE_WRITE) {
janet_schedule(writer.fiber, janet_wrap_nil());
} else {
janet_schedule(writer.fiber, make_close_result(channel));
} else {
janet_schedule(writer.fiber, janet_wrap_nil());
}
}
}
@@ -1141,9 +1188,9 @@ JANET_CORE_FN(cfun_channel_close,
janet_ev_post_event(vm, janet_thread_chan_cb, msg);
} else {
if (reader.mode == JANET_CP_MODE_CHOICE_READ) {
janet_schedule(reader.fiber, janet_wrap_nil());
} else {
janet_schedule(reader.fiber, make_close_result(channel));
} else {
janet_schedule(reader.fiber, janet_wrap_nil());
}
}
}
@@ -1175,14 +1222,48 @@ static Janet janet_chanat_next(void *p, Janet key) {
return janet_nextmethod(ev_chanat_methods, key);
}
static void janet_chanat_marshal(void *p, JanetMarshalContext *ctx) {
JanetChannel *channel = (JanetChannel *)p;
janet_marshal_byte(ctx, channel->closed);
janet_marshal_int(ctx, channel->limit);
int32_t count = janet_q_count(&channel->items);
janet_marshal_int(ctx, count);
JanetQueue *items = &channel->items;
Janet *data = channel->items.data;
if (items->head <= items->tail) {
for (int32_t i = items->head; i < items->tail; i++)
janet_marshal_janet(ctx, data[i]);
} else {
for (int32_t i = items->head; i < items->capacity; i++)
janet_marshal_janet(ctx, data[i]);
for (int32_t i = 0; i < items->tail; i++)
janet_marshal_janet(ctx, data[i]);
}
}
static void *janet_chanat_unmarshal(JanetMarshalContext *ctx) {
JanetChannel *abst = janet_unmarshal_abstract(ctx, sizeof(JanetChannel));
uint8_t is_closed = janet_unmarshal_byte(ctx);
int32_t limit = janet_unmarshal_int(ctx);
int32_t count = janet_unmarshal_int(ctx);
if (count < 0) janet_panic("invalid negative channel count");
janet_chan_init(abst, limit, 0);
abst->closed = !!is_closed;
for (int32_t i = 0; i < count; i++) {
Janet item = janet_unmarshal_janet(ctx);
janet_q_push(&abst->items, &item, sizeof(item));
}
return abst;
}
const JanetAbstractType janet_channel_type = {
"core/channel",
janet_chanat_gc,
janet_chanat_mark,
janet_chanat_get,
NULL, /* put */
NULL, /* marshal */
NULL, /* unmarshal */
janet_chanat_marshal,
janet_chanat_unmarshal,
NULL, /* tostring */
NULL, /* compare */
NULL, /* hash */
@@ -1208,16 +1289,7 @@ JanetFiber *janet_loop1(void) {
while (peek_timeout(&to) && to.when <= now) {
pop_timeout(0);
if (to.curr_fiber != NULL) {
/* This is a deadline (for a fiber, not a function call) */
JanetFiberStatus s = janet_fiber_status(to.curr_fiber);
int isFinished = (s == JANET_STATUS_DEAD ||
s == JANET_STATUS_ERROR ||
s == JANET_STATUS_USER0 ||
s == JANET_STATUS_USER1 ||
s == JANET_STATUS_USER2 ||
s == JANET_STATUS_USER3 ||
s == JANET_STATUS_USER4);
if (!isFinished) {
if (janet_fiber_can_resume(to.curr_fiber)) {
janet_cancel(to.fiber, janet_cstringv("deadline expired"));
}
} else {
@@ -1241,6 +1313,9 @@ JanetFiber *janet_loop1(void) {
if (task.expected_sched_id != task.fiber->sched_id) continue;
Janet res;
JanetSignal sig = janet_continue_signal(task.fiber, task.value, &res, task.sig);
if (!janet_fiber_can_resume(task.fiber)) {
janet_table_remove(&janet_vm.active_tasks, janet_wrap_fiber(task.fiber));
}
void *sv = task.fiber->supervisor_channel;
int is_suspended = sig == JANET_SIGNAL_EVENT || sig == JANET_SIGNAL_YIELD || sig == JANET_SIGNAL_INTERRUPT;
if (is_suspended) {
@@ -1272,15 +1347,8 @@ JanetFiber *janet_loop1(void) {
/* Drop timeouts that are no longer needed */
while ((has_timeout = peek_timeout(&to))) {
if (to.curr_fiber != NULL) {
JanetFiberStatus s = janet_fiber_status(to.curr_fiber);
int is_finished = (s == JANET_STATUS_DEAD ||
s == JANET_STATUS_ERROR ||
s == JANET_STATUS_USER0 ||
s == JANET_STATUS_USER1 ||
s == JANET_STATUS_USER2 ||
s == JANET_STATUS_USER3 ||
s == JANET_STATUS_USER4);
if (is_finished) {
if (!janet_fiber_can_resume(to.curr_fiber)) {
janet_table_remove(&janet_vm.active_tasks, janet_wrap_fiber(to.curr_fiber));
pop_timeout(0);
continue;
}
@@ -1383,7 +1451,6 @@ JanetListenerState *janet_listen(JanetStream *stream, JanetListener behavior, in
return state;
}
static void janet_unlisten(JanetListenerState *state, int is_gc) {
janet_unlisten_impl(state, is_gc);
}
@@ -1432,6 +1499,10 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp to) {
state = state->_next;
}
}
/* Close the stream if requested and no more listeners are left */
if ((stream->flags & JANET_STREAM_TOCLOSE) && !stream->state) {
janet_stream_close(stream);
}
}
}
}
@@ -1586,6 +1657,10 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) {
janet_unlisten(state, 0);
state = next_state;
}
/* Close the stream if requested and no more listeners are left */
if ((stream->flags & JANET_STREAM_TOCLOSE) && !stream->state) {
janet_stream_close(stream);
}
}
}
}
@@ -1784,6 +1859,10 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) {
state = next_state;
}
/* Close the stream if requested and no more listeners are left */
if ((stream->flags & JANET_STREAM_TOCLOSE) && !stream->state) {
janet_stream_close(stream);
}
}
}
}
@@ -1887,6 +1966,7 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) {
JanetAsyncStatus status3 = JANET_ASYNC_STATUS_NOT_DONE;
JanetAsyncStatus status4 = JANET_ASYNC_STATUS_NOT_DONE;
state->event = pfd;
JanetStream *stream = state->stream;
if (mask & POLLOUT)
status1 = state->machine(state, JANET_ASYNC_EVENT_WRITE);
if (mask & POLLIN)
@@ -1900,6 +1980,10 @@ void janet_loop1_impl(int has_timeout, JanetTimestamp timeout) {
status3 == JANET_ASYNC_STATUS_DONE ||
status4 == JANET_ASYNC_STATUS_DONE)
janet_unlisten(state, 0);
/* Close the stream if requested and no more listeners are left */
if ((stream->flags & JANET_STREAM_TOCLOSE) && !stream->state) {
janet_stream_close(stream);
}
}
}
@@ -2038,12 +2122,11 @@ void janet_ev_threaded_call(JanetThreadedSubroutine fp, JanetEVGenericMessage ar
#else
init->write_pipe = janet_vm.selfpipe[1];
pthread_t waiter_thread;
int err = pthread_create(&waiter_thread, NULL, janet_thread_body, init);
int err = pthread_create(&waiter_thread, &janet_vm.new_thread_attr, janet_thread_body, init);
if (err) {
janet_free(init);
janet_panicf("%s", strerror(err));
}
pthread_detach(waiter_thread);
#endif
/* Increment ev refcount so we don't quit while waiting for a subprocess */
@@ -2087,7 +2170,6 @@ void janet_ev_default_threaded_callback(JanetEVGenericMessage return_value) {
janet_gcunroot(janet_wrap_fiber(return_value.fiber));
}
/* Convenience method for common case */
JANET_NO_RETURN
void janet_ev_threaded_await(JanetThreadedSubroutine fp, int tag, int argi, void *argp) {
@@ -2172,9 +2254,9 @@ typedef struct {
JanetReadMode mode;
#ifdef JANET_WINDOWS
OVERLAPPED overlapped;
DWORD flags;
#ifdef JANET_NET
WSABUF wbuf;
DWORD flags;
struct sockaddr from;
int fromlen;
#endif
@@ -2233,7 +2315,8 @@ JanetAsyncStatus ev_machine_read(JanetListenerState *s, JanetAsyncEvent event) {
#ifdef JANET_NET
if (state->mode == JANET_ASYNC_READMODE_RECVFROM) {
state->wbuf.len = (ULONG) chunk_size;
state->wbuf.buf = state->chunk_buf;
state->wbuf.buf = (char *) state->chunk_buf;
state->fromlen = sizeof(state->from);
status = WSARecvFrom((SOCKET) s->stream->handle, &state->wbuf, 1,
NULL, &state->flags, &state->from, &state->fromlen, &state->overlapped, NULL);
if (status && (WSA_IO_PENDING != WSAGetLastError())) {
@@ -2248,8 +2331,8 @@ JanetAsyncStatus ev_machine_read(JanetListenerState *s, JanetAsyncEvent event) {
state->overlapped.Offset = (DWORD) state->bytes_read;
status = ReadFile(s->stream->handle, state->chunk_buf, chunk_size, NULL, &state->overlapped);
if (!status && (ERROR_IO_PENDING != WSAGetLastError())) {
if (WSAGetLastError() == ERROR_BROKEN_PIPE) {
if (!status && (ERROR_IO_PENDING != GetLastError())) {
if (GetLastError() == ERROR_BROKEN_PIPE) {
if (state->bytes_read) {
janet_schedule(s->fiber, janet_wrap_buffer(state->buf));
} else {
@@ -2387,7 +2470,8 @@ void janet_ev_recvfrom(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, in
typedef enum {
JANET_ASYNC_WRITEMODE_WRITE,
JANET_ASYNC_WRITEMODE_SEND,
JANET_ASYNC_WRITEMODE_SENDTO
JANET_ASYNC_WRITEMODE_SENDTO,
JANET_ASYNC_WRITEMODE_CONNECT
} JanetWriteMode;
typedef struct {
@@ -2401,9 +2485,9 @@ typedef struct {
void *dest_abst;
#ifdef JANET_WINDOWS
OVERLAPPED overlapped;
DWORD flags;
#ifdef JANET_NET
WSABUF wbuf;
DWORD flags;
#endif
#else
int flags;
@@ -2411,6 +2495,30 @@ typedef struct {
#endif
} StateWrite;
static JanetAsyncStatus handle_connect(JanetListenerState *s) {
#ifdef JANET_WINDOWS
int res = 0;
int size = sizeof(res);
int r = getsockopt((SOCKET)s->stream->handle, SOL_SOCKET, SO_ERROR, (char *)&res, &size);
#else
int res = 0;
socklen_t size = sizeof res;
int r = getsockopt(s->stream->handle, SOL_SOCKET, SO_ERROR, &res, &size);
#endif
if (r == 0) {
if (res == 0) {
janet_schedule(s->fiber, janet_wrap_abstract(s->stream));
} else {
s->stream->flags |= JANET_STREAM_TOCLOSE;
janet_cancel(s->fiber, janet_cstringv(strerror(res)));
}
} else {
s->stream->flags |= JANET_STREAM_TOCLOSE;
janet_cancel(s->fiber, janet_ev_lasterr());
}
return JANET_ASYNC_STATUS_DONE;
}
JanetAsyncStatus ev_machine_write(JanetListenerState *s, JanetAsyncEvent event) {
StateWrite *state = (StateWrite *) s;
switch (event) {
@@ -2440,6 +2548,11 @@ JanetAsyncStatus ev_machine_write(JanetListenerState *s, JanetAsyncEvent event)
}
break;
case JANET_ASYNC_EVENT_USER: {
#ifdef JANET_NET
if (state->mode == JANET_ASYNC_WRITEMODE_CONNECT) {
return handle_connect(s);
}
#endif
/* Begin write */
int32_t len;
const uint8_t *bytes;
@@ -2488,7 +2601,7 @@ JanetAsyncStatus ev_machine_write(JanetListenerState *s, JanetAsyncEvent event)
state->overlapped.Offset = (DWORD) 0xFFFFFFFF;
state->overlapped.OffsetHigh = (DWORD) 0xFFFFFFFF;
status = WriteFile(s->stream->handle, bytes, len, NULL, &state->overlapped);
if (!status && (ERROR_IO_PENDING != WSAGetLastError())) {
if (!status && (ERROR_IO_PENDING != GetLastError())) {
janet_cancel(s->fiber, janet_ev_lasterr());
return JANET_ASYNC_STATUS_DONE;
}
@@ -2503,6 +2616,11 @@ JanetAsyncStatus ev_machine_write(JanetListenerState *s, JanetAsyncEvent event)
janet_cancel(s->fiber, janet_cstringv("stream hup"));
return JANET_ASYNC_STATUS_DONE;
case JANET_ASYNC_EVENT_WRITE: {
#ifdef JANET_NET
if (state->mode == JANET_ASYNC_WRITEMODE_CONNECT) {
return handle_connect(s);
}
#endif
int32_t start, len;
const uint8_t *bytes;
start = state->start;
@@ -2580,7 +2698,6 @@ static void janet_ev_write_generic(JanetStream *stream, void *buf, void *dest_ab
#endif
}
void janet_ev_write_buffer(JanetStream *stream, JanetBuffer *buf) {
janet_ev_write_generic(stream, buf, NULL, JANET_ASYNC_WRITEMODE_WRITE, 1, 0);
}
@@ -2605,6 +2722,10 @@ void janet_ev_sendto_buffer(JanetStream *stream, JanetBuffer *buf, void *dest, i
void janet_ev_sendto_string(JanetStream *stream, JanetString str, void *dest, int flags) {
janet_ev_write_generic(stream, (void *) str, dest, JANET_ASYNC_WRITEMODE_SENDTO, 0, flags);
}
void janet_ev_connect(JanetStream *stream, int flags) {
janet_ev_write_generic(stream, NULL, NULL, JANET_ASYNC_WRITEMODE_CONNECT, 0, flags);
}
#endif
/* For a pipe ID */
@@ -2624,15 +2745,15 @@ int janet_make_pipe(JanetHandle handles[2], int mode) {
* so we lift from the windows source code and modify for our own version.
*/
JanetHandle shandle, chandle;
UCHAR PipeNameBuffer[MAX_PATH];
CHAR PipeNameBuffer[MAX_PATH];
SECURITY_ATTRIBUTES saAttr;
memset(&saAttr, 0, sizeof(saAttr));
saAttr.nLength = sizeof(saAttr);
saAttr.bInheritHandle = TRUE;
sprintf(PipeNameBuffer,
"\\\\.\\Pipe\\JanetPipeFile.%08x.%08x",
GetCurrentProcessId(),
InterlockedIncrement(&PipeSerialNumber));
(unsigned int) GetCurrentProcessId(),
(unsigned int) InterlockedIncrement(&PipeSerialNumber));
/* server handle goes to subprocess */
shandle = CreateNamedPipeA(
@@ -2688,7 +2809,7 @@ 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"
"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 "
@@ -2735,6 +2856,7 @@ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) {
uint32_t flags = args.tag;
args.tag = 0;
janet_init();
janet_vm.sandbox_flags = (uint32_t) args.argi;
JanetTryState tstate;
JanetSignal signal = janet_try(&tstate);
if (!signal) {
@@ -2784,13 +2906,13 @@ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) {
JanetFiber *fiber;
if (!janet_checktype(fiberv, JANET_FIBER)) {
if (!janet_checktype(fiberv, JANET_FUNCTION)) {
janet_panicf("expected function|fiber, got %v", fiberv);
janet_panicf("expected function or fiber, got %v", fiberv);
}
JanetFunction *func = janet_unwrap_function(fiberv);
if (func->def->min_arity > 1) {
fiber = janet_fiber(func, 64, func->def->min_arity, &value);
if (fiber == NULL) {
janet_panicf("thread function must accept 0 or 1 arguments");
}
fiber = janet_fiber(func, 64, func->def->min_arity, &value);
fiber->flags |=
JANET_FIBER_MASK_ERROR |
JANET_FIBER_MASK_USER0 |
@@ -2887,19 +3009,19 @@ JANET_CORE_FN(cfun_ev_thread,
JanetEVGenericMessage arguments;
memset(&arguments, 0, sizeof(arguments));
arguments.tag = (uint32_t) flags;
arguments.argi = argc;
arguments.argi = (uint32_t) janet_vm.sandbox_flags;
arguments.argp = buffer;
arguments.fiber = NULL;
janet_ev_threaded_call(janet_go_thread_subr, arguments, janet_ev_default_threaded_callback);
return janet_wrap_nil();
} else {
janet_ev_threaded_await(janet_go_thread_subr, (uint32_t) flags, argc, buffer);
janet_ev_threaded_await(janet_go_thread_subr, (uint32_t) flags, (uint32_t) janet_vm.sandbox_flags, buffer);
}
}
JANET_CORE_FN(cfun_ev_give_supervisor,
"(ev/give-supervisor tag & payload)",
"Send a message to the current supervior channel if there is one. The message will be a "
"Send a message to the current supervisor channel if there is one. The message will be a "
"tuple of all of the arguments combined into a single message, where the first element is tag. "
"By convention, tag should be a keyword indicating the type of message. Returns nil.") {
janet_arity(argc, 1, -1);
@@ -3130,6 +3252,20 @@ JANET_CORE_FN(janet_cfun_rwlock_write_release,
return argv[0];
}
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.") {
janet_fixarity(argc, 0);
(void) argv;
JanetArray *array = janet_array(janet_vm.active_tasks.count);
for (int32_t i = 0; i < janet_vm.active_tasks.capacity; i++) {
if (!janet_checktype(janet_vm.active_tasks.data[i].key, JANET_NIL)) {
janet_array_push(array, janet_vm.active_tasks.data[i].key);
}
}
return janet_wrap_array(array);
}
void janet_lib_ev(JanetTable *env) {
JanetRegExt ev_cfuns_ext[] = {
JANET_CORE_REG("ev/give", cfun_channel_push),
@@ -3160,6 +3296,7 @@ void janet_lib_ev(JanetTable *env) {
JANET_CORE_REG("ev/acquire-wlock", janet_cfun_rwlock_write_lock),
JANET_CORE_REG("ev/release-rlock", janet_cfun_rwlock_read_release),
JANET_CORE_REG("ev/release-wlock", janet_cfun_rwlock_write_release),
JANET_CORE_REG("ev/all-tasks", janet_cfun_ev_all_tasks),
JANET_REG_END
};

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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,9 +26,10 @@
#define JANET_FEATURES_H_defined
#if defined(__NetBSD__) || defined(__APPLE__) || defined(__OpenBSD__) \
|| defined(__bsdi__) || defined(__DragonFly__)
|| defined(__bsdi__) || defined(__DragonFly__) || defined(__FreeBSD__)
/* Use BSD source on any BSD systems, include OSX */
# define _BSD_SOURCE
# define _POSIX_C_SOURCE 200809L
#else
/* Use POSIX feature flags */
# ifndef _POSIX_C_SOURCE
@@ -36,6 +37,10 @@
# endif
#endif
#if defined(__APPLE__)
#define _DARWIN_C_SOURCE
#endif
/* Needed for sched.h for cpu count */
#ifdef __linux__
#define _GNU_SOURCE
@@ -45,6 +50,11 @@
#define WIN32_LEAN_AND_MEAN
#endif
/* needed for inet_pton and InitializeSRWLock */
#ifdef __MINGW32__
#define _WIN32_WINNT _WIN32_WINNT_VISTA
#endif
/* Needed for realpath on linux, as well as pthread rwlocks. */
#ifndef _XOPEN_SOURCE
#define _XOPEN_SOURCE 600
@@ -61,4 +71,9 @@
#define _NETBSD_SOURCE
#endif
/* Needed for several things when building with -std=c99. */
#if !__BSD_VISIBLE && (defined(__DragonFly__) || defined(__FreeBSD__))
#define __BSD_VISIBLE 1
#endif
#endif

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -24,6 +24,7 @@
#include "features.h"
#include <janet.h>
#include "util.h"
#include "gc.h"
#endif
#ifdef JANET_FFI
@@ -37,6 +38,13 @@
#define alloca __builtin_alloca
#endif
/* FFI jit includes */
#ifdef JANET_FFI_JIT
#ifndef JANET_WINDOWS
#include <sys/mman.h>
#endif
#endif
#define JANET_FFI_MAX_RECUR 64
/* Compiler, OS, and arch detection. Used
@@ -202,6 +210,11 @@ int struct_mark(void *p, size_t s) {
return 0;
}
typedef struct {
void *function_pointer;
size_t size;
} JanetFFIJittedFn;
static const JanetAbstractType janet_struct_type = {
"core/ffi-struct",
NULL,
@@ -209,6 +222,42 @@ static const JanetAbstractType janet_struct_type = {
JANET_ATEND_GCMARK
};
static int janet_ffijit_gc(void *p, size_t s) {
(void) s;
JanetFFIJittedFn *fn = p;
if (fn->function_pointer == NULL) return 0;
#ifdef JANET_FFI_JIT
#ifdef JANET_WINDOWS
VirtualFree(fn->function_pointer, fn->size, MEM_RELEASE);
#else
munmap(fn->function_pointer, fn->size);
#endif
#endif
return 0;
}
static JanetByteView janet_ffijit_getbytes(void *p, size_t s) {
(void) s;
JanetFFIJittedFn *fn = p;
JanetByteView bytes;
bytes.bytes = fn->function_pointer;
bytes.len = (int32_t) fn->size;
return bytes;
}
static size_t janet_ffijit_length(void *p, size_t s) {
(void) s;
JanetFFIJittedFn *fn = p;
return fn->size;
}
const JanetAbstractType janet_type_ffijit = {
.name = "ffi/jitfn",
.gc = janet_ffijit_gc,
.bytes = janet_ffijit_getbytes,
.length = janet_ffijit_length
};
typedef struct {
Clib clib;
int closed;
@@ -261,6 +310,7 @@ static JanetFFIPrimType decode_ffi_prim(const uint8_t *name) {
if (!janet_cstrcmp(name, "void")) return JANET_FFI_TYPE_VOID;
if (!janet_cstrcmp(name, "bool")) return JANET_FFI_TYPE_BOOL;
if (!janet_cstrcmp(name, "ptr")) return JANET_FFI_TYPE_PTR;
if (!janet_cstrcmp(name, "pointer")) return JANET_FFI_TYPE_PTR;
if (!janet_cstrcmp(name, "string")) return JANET_FFI_TYPE_STRING;
if (!janet_cstrcmp(name, "float")) return JANET_FFI_TYPE_FLOAT;
if (!janet_cstrcmp(name, "double")) return JANET_FFI_TYPE_DOUBLE;
@@ -425,13 +475,15 @@ JANET_CORE_FN(cfun_ffi_align,
static void *janet_ffi_getpointer(const Janet *argv, int32_t n) {
switch (janet_type(argv[n])) {
default:
janet_panicf("bad slot #%d, expected ffi pointer convertable type, got %v", argv[n]);
janet_panicf("bad slot #%d, expected ffi pointer convertable type, got %v", n, argv[n]);
case JANET_POINTER:
case JANET_STRING:
case JANET_KEYWORD:
case JANET_SYMBOL:
case JANET_ABSTRACT:
case JANET_CFUNCTION:
return janet_unwrap_pointer(argv[n]);
case JANET_ABSTRACT:
return (void *) janet_getbytes(argv, n).bytes;
case JANET_BUFFER:
return janet_unwrap_buffer(argv[n])->data;
case JANET_FUNCTION:
@@ -444,6 +496,19 @@ static void *janet_ffi_getpointer(const Janet *argv, int32_t n) {
}
}
static void *janet_ffi_get_callable_pointer(const Janet *argv, int32_t n) {
switch (janet_type(argv[n])) {
default:
break;
case JANET_POINTER:
return janet_unwrap_pointer(argv[n]);
case JANET_ABSTRACT:
if (!janet_checkabstract(argv[n], &janet_type_ffijit)) break;
return ((JanetFFIJittedFn *)janet_unwrap_abstract(argv[n]))->function_pointer;
}
janet_panicf("bad slot #%d, expected ffi callable pointer type, got %v", n, argv[n]);
}
/* Write a value given by some Janet values and an FFI type as it would appear in memory.
* The alignment and space available is assumed to already be sufficient */
static void janet_ffi_write_one(void *to, const Janet *argv, int32_t n, JanetFFIType type, int recur) {
@@ -775,7 +840,6 @@ JANET_CORE_FN(cfun_ffi_signature,
}
/* Add reference items */
size_t old_stack_count = stack_count;
stack_count += 2 * ref_stack_count;
if (stack_count & 0x1) {
stack_count++;
@@ -1116,7 +1180,13 @@ static Janet janet_ffi_win64(JanetFFISignature *signature, void *function_pointe
/* hack to get proper stack placement and avoid clobbering from logic above - shift stack down, otherwise we have issues.
* Technically, this writes into 16 bytes of unallocated stack memory */
#ifdef JANET_MINGW
#pragma GCC diagnostic ignored "-Wstringop-overflow"
#endif
if (stack_size) memmove(stack - stack_shift, stack, stack_size);
#ifdef JANET_MINGW
#pragma GCC diagnostic pop
#endif
switch (signature->variant) {
default:
@@ -1224,17 +1294,77 @@ static Janet janet_ffi_win64(JanetFFISignature *signature, void *function_pointe
#endif
/* Allocate executable memory chunks in sizes of a page. Ideally we would keep
* an allocator around so that multiple JIT allocations would point to the same
* region but it isn't really worth it. */
#define FFI_PAGE_MASK 0xFFF
JANET_CORE_FN(cfun_ffi_jitfn,
"(ffi/jitfn bytes)",
"Create an abstract type that can be used as the pointer argument to `ffi/call`. The content "
"of `bytes` is architecture specific machine code that will be copied into executable memory.") {
janet_sandbox_assert(JANET_SANDBOX_FFI_JIT);
janet_fixarity(argc, 1);
JanetByteView bytes = janet_getbytes(argv, 0);
/* Quick hack to align to page boundary, we should query OS. FIXME */
size_t alloc_size = ((size_t) bytes.len + FFI_PAGE_MASK) & ~FFI_PAGE_MASK;
#ifdef JANET_FFI_JIT
#ifdef JANET_EV
JanetFFIJittedFn *fn = janet_abstract_threaded(&janet_type_ffijit, sizeof(JanetFFIJittedFn));
#else
JanetFFIJittedFn *fn = janet_abstract(&janet_type_ffijit, sizeof(JanetFFIJittedFn));
#endif
fn->function_pointer = NULL;
fn->size = 0;
#ifdef JANET_WINDOWS
void *ptr = VirtualAlloc(NULL, alloc_size, MEM_COMMIT | MEM_RESERVE, PAGE_READWRITE);
#elif defined(MAP_ANONYMOUS)
void *ptr = mmap(0, alloc_size, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0);
#elif defined(MAP_ANON)
/* macos doesn't have MAP_ANONYMOUS */
void *ptr = mmap(0, alloc_size, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANON, -1, 0);
#else
/* -std=c99 gets in the way */
/* #define MAP_ANONYMOUS 0x20 should work, though. */
void *ptr = mmap(0, alloc_size, PROT_READ | PROT_WRITE, MAP_PRIVATE, -1, 0);
#endif
if (!ptr) {
janet_panic("failed to memory map writable memory");
}
memcpy(ptr, bytes.bytes, bytes.len);
#ifdef JANET_WINDOWS
DWORD old = 0;
if (!VirtualProtect(ptr, alloc_size, PAGE_EXECUTE_READ, &old)) {
janet_panic("failed to make mapped memory executable");
}
#else
if (mprotect(ptr, alloc_size, PROT_READ | PROT_EXEC) == -1) {
janet_panic("failed to make mapped memory executable");
}
#endif
fn->size = alloc_size;
fn->function_pointer = ptr;
return janet_wrap_abstract(fn);
#else
janet_panic("ffi/jitfn not available on this platform");
#endif
}
JANET_CORE_FN(cfun_ffi_call,
"(ffi/call pointer signature & args)",
"Call a raw pointer as a function pointer. The function signature specifies "
"how Janet values in `args` are converted to native machine types.") {
janet_sandbox_assert(JANET_SANDBOX_FFI_USE);
janet_arity(argc, 2, -1);
void *function_pointer = janet_getpointer(argv, 0);
void *function_pointer = janet_ffi_get_callable_pointer(argv, 0);
JanetFFISignature *signature = janet_getabstract(argv, 1, &janet_signature_type);
janet_fixarity(argc - 2, signature->arg_count);
switch (signature->cc) {
default:
case JANET_FFI_CC_NONE:
(void) function_pointer;
janet_panic("calling convention not supported");
#ifdef JANET_FFI_WIN64_ENABLED
case JANET_FFI_CC_WIN_64:
@@ -1248,18 +1378,25 @@ JANET_CORE_FN(cfun_ffi_call,
}
JANET_CORE_FN(cfun_ffi_buffer_write,
"(ffi/write ffi-type data &opt buffer)",
"Append a native tyep to a buffer such as it would appear in memory. This can be used "
"(ffi/write ffi-type data &opt buffer index)",
"Append a native type to a buffer such as it would appear in memory. This can be used "
"to pass pointers to structs in the ffi, or send C/C++/native structs over the network "
"or to files. Returns a modifed buffer or a new buffer if one is not supplied.") {
janet_arity(argc, 2, 3);
janet_sandbox_assert(JANET_SANDBOX_FFI_USE);
janet_arity(argc, 2, 4);
JanetFFIType type = decode_ffi_type(argv[0]);
uint32_t el_size = (uint32_t) type_size(type);
JanetBuffer *buffer = janet_optbuffer(argv, argc, 2, el_size);
int32_t index = janet_optnat(argv, argc, 3, 0);
int32_t old_count = buffer->count;
if (index > old_count) janet_panic("index out of bounds");
buffer->count = index;
janet_buffer_extra(buffer, el_size);
memset(buffer->data, 0, el_size);
janet_ffi_write_one(buffer->data, argv, 1, type, JANET_FFI_MAX_RECUR);
buffer->count += el_size;
buffer->count = old_count;
memset(buffer->data + index, 0, el_size);
janet_ffi_write_one(buffer->data + index, argv, 1, type, JANET_FFI_MAX_RECUR);
index += el_size;
if (buffer->count < index) buffer->count = index;
return janet_wrap_buffer(buffer);
}
@@ -1268,6 +1405,7 @@ JANET_CORE_FN(cfun_ffi_buffer_read,
"Parse a native struct out of a buffer and convert it to normal Janet data structures. "
"This function is the inverse of `ffi/write`. `bytes` can also be a raw pointer, although "
"this is unsafe.") {
janet_sandbox_assert(JANET_SANDBOX_FFI_USE);
janet_arity(argc, 2, 3);
JanetFFIType type = decode_ffi_type(argv[0]);
size_t offset = (size_t) janet_optnat(argv, argc, 2, 0);
@@ -1314,6 +1452,7 @@ JANET_CORE_FN(janet_core_raw_native,
" or run any code from it. This is different than `native`, which will "
"run initialization code to get a module table. If `path` is nil, opens the current running binary. "
"Returns a `core/native`.") {
janet_sandbox_assert(JANET_SANDBOX_FFI_DEFINE);
janet_arity(argc, 0, 1);
const char *path = janet_optcstring(argv, argc, 0, NULL);
Clib lib = load_clib(path);
@@ -1329,6 +1468,7 @@ JANET_CORE_FN(janet_core_native_lookup,
"(ffi/lookup native symbol-name)",
"Lookup a symbol from a native object. All symbol lookups will return a raw pointer "
"if the symbol is found, else nil.") {
janet_sandbox_assert(JANET_SANDBOX_FFI_DEFINE);
janet_fixarity(argc, 2);
JanetAbstractNative *anative = janet_getabstract(argv, 0, &janet_native_type);
const char *sym = janet_getcstring(argv, 1);
@@ -1342,6 +1482,7 @@ JANET_CORE_FN(janet_core_native_close,
"(ffi/close native)",
"Free a native object. Dereferencing pointers to symbols in the object will have undefined "
"behavior after freeing.") {
janet_sandbox_assert(JANET_SANDBOX_FFI_DEFINE);
janet_fixarity(argc, 1);
JanetAbstractNative *anative = janet_getabstract(argv, 0, &janet_native_type);
if (anative->closed) janet_panic("native object already closed");
@@ -1351,6 +1492,64 @@ JANET_CORE_FN(janet_core_native_close,
return janet_wrap_nil();
}
JANET_CORE_FN(cfun_ffi_malloc,
"(ffi/malloc size)",
"Allocates memory directly using the janet memory allocator. Memory allocated in this way must be freed manually! Returns a raw pointer, or nil if size = 0.") {
janet_sandbox_assert(JANET_SANDBOX_FFI_USE);
janet_fixarity(argc, 1);
size_t size = janet_getsize(argv, 0);
if (size == 0) return janet_wrap_nil();
return janet_wrap_pointer(janet_malloc(size));
}
JANET_CORE_FN(cfun_ffi_free,
"(ffi/free pointer)",
"Free memory allocated with `ffi/malloc`. Returns nil.") {
janet_sandbox_assert(JANET_SANDBOX_FFI_USE);
janet_fixarity(argc, 1);
if (janet_checktype(argv[0], JANET_NIL)) return janet_wrap_nil();
void *pointer = janet_getpointer(argv, 0);
janet_free(pointer);
return janet_wrap_nil();
}
JANET_CORE_FN(cfun_ffi_pointer_buffer,
"(ffi/pointer-buffer pointer capacity &opt count offset)",
"Create a buffer from a pointer. The underlying memory of the buffer will not be "
"reallocated or freed by the garbage collector, allowing unmanaged, mutable memory "
"to be manipulated with buffer functions. Attempts to resize or extend the buffer "
"beyond its initial capacity will raise an error. As with many FFI functions, this is memory "
"unsafe and can potentially allow out of bounds memory access. Returns a new buffer.") {
janet_sandbox_assert(JANET_SANDBOX_FFI_USE);
janet_arity(argc, 2, 4);
void *pointer = janet_getpointer(argv, 0);
int32_t capacity = janet_getnat(argv, 1);
int32_t count = janet_optnat(argv, argc, 2, 0);
int64_t offset = janet_optinteger64(argv, argc, 3, 0);
uint8_t *offset_pointer = ((uint8_t *) pointer) + offset;
return janet_wrap_buffer(janet_pointer_buffer_unsafe(offset_pointer, capacity, count));
}
JANET_CORE_FN(cfun_ffi_supported_calling_conventions,
"(ffi/calling-conventions)",
"Get an array of all supported calling conventions on the current arhcitecture. Some architectures may have some FFI "
"functionality (ffi/malloc, ffi/free, ffi/read, ffi/write, etc.) but not support "
"any calling conventions. This function can be used to get all supported calling conventions "
"that can be used on this architecture. All architectures support the :none calling "
"convention which is a placeholder that cannot be used at runtime.") {
janet_fixarity(argc, 0);
(void) argv;
JanetArray *array = janet_array(4);
#ifdef JANET_FFI_WIN64_ENABLED
janet_array_push(array, janet_ckeywordv("win64"));
#endif
#ifdef JANET_FFI_SYSV64_ENABLED
janet_array_push(array, janet_ckeywordv("sysv64"));
#endif
janet_array_push(array, janet_ckeywordv("none"));
return janet_wrap_array(array);
}
void janet_lib_ffi(JanetTable *env) {
JanetRegExt ffi_cfuns[] = {
JANET_CORE_REG("ffi/native", janet_core_raw_native),
@@ -1364,6 +1563,11 @@ void janet_lib_ffi(JanetTable *env) {
JANET_CORE_REG("ffi/size", cfun_ffi_size),
JANET_CORE_REG("ffi/align", cfun_ffi_align),
JANET_CORE_REG("ffi/trampoline", cfun_ffi_get_callback_trampoline),
JANET_CORE_REG("ffi/jitfn", cfun_ffi_jitfn),
JANET_CORE_REG("ffi/malloc", cfun_ffi_malloc),
JANET_CORE_REG("ffi/free", cfun_ffi_free),
JANET_CORE_REG("ffi/pointer-buffer", cfun_ffi_pointer_buffer),
JANET_CORE_REG("ffi/calling-conventions", cfun_ffi_supported_calling_conventions),
JANET_REG_END
};
janet_core_cfuns_ext(env, NULL, ffi_cfuns);

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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,6 +81,7 @@ JanetFiber *janet_fiber_reset(JanetFiber *fiber, JanetFunction *callee, int32_t
}
fiber->stacktop = newstacktop;
}
/* Don't panic on failure since we use this to implement janet_pcall */
if (janet_fiber_funcframe(fiber, callee)) return NULL;
janet_fiber_frame(fiber)->flags |= JANET_STACKFRAME_ENTRANCE;
#ifdef JANET_EV
@@ -477,10 +478,10 @@ JANET_CORE_FN(cfun_fiber_setenv,
}
JANET_CORE_FN(cfun_fiber_new,
"(fiber/new func &opt sigmask)",
"(fiber/new func &opt sigmask env)",
"Create a new fiber with function body func. Can optionally "
"take a set of signals to block from the current parent fiber "
"when called. The mask is specified as a keyword where each character "
"take a set of signals `sigmask` to capture from child fibers, "
"and an environment table `env`. The mask is specified as a keyword where each character "
"is used to indicate a signal to block. If the ev module is enabled, and "
"this fiber is used as an argument to `ev/go`, these \"blocked\" signals "
"will result in messages being sent to the supervisor channel. "
@@ -495,19 +496,25 @@ JANET_CORE_FN(cfun_fiber_new,
"* :t - block termination signals: error + user[0-4]\n"
"* :u - block user signals\n"
"* :y - block yield signals\n"
"* :w - block await signals (user9)\n"
"* :r - block interrupt signals (user8)\n"
"* :0-9 - block a specific user signal\n\n"
"The sigmask argument also can take environment flags. If any mutually "
"exclusive flags are present, the last flag takes precedence.\n\n"
"* :i - inherit the environment from the current fiber\n"
"* :p - the environment table's prototype is the current environment table") {
janet_arity(argc, 1, 2);
janet_arity(argc, 1, 3);
JanetFunction *func = janet_getfunction(argv, 0);
JanetFiber *fiber;
if (func->def->min_arity > 1) {
janet_panicf("fiber function must accept 0 or 1 arguments");
}
fiber = janet_fiber(func, 64, func->def->min_arity, NULL);
if (argc == 2) {
janet_assert(fiber != NULL, "bad fiber arity check");
if (argc == 3 && !janet_checktype(argv[2], JANET_NIL)) {
fiber->env = janet_gettable(argv, 2);
}
if (argc >= 2) {
int32_t i;
JanetByteView view = janet_getbytes(argv, 1);
fiber->flags = JANET_FIBER_RESUME_NO_USEVAL | JANET_FIBER_RESUME_NO_SKIP;
@@ -518,7 +525,7 @@ JANET_CORE_FN(cfun_fiber_new,
} else {
switch (view.bytes[i]) {
default:
janet_panicf("invalid flag %c, expected a, t, d, e, u, y, i, or p", view.bytes[i]);
janet_panicf("invalid flag %c, expected a, t, d, e, u, y, w, r, i, or p", view.bytes[i]);
break;
case 'a':
fiber->flags |=
@@ -548,6 +555,12 @@ JANET_CORE_FN(cfun_fiber_new,
case 'y':
fiber->flags |= JANET_FIBER_MASK_YIELD;
break;
case 'w':
fiber->flags |= JANET_FIBER_MASK_USER9;
break;
case 'r':
fiber->flags |= JANET_FIBER_MASK_USER8;
break;
case 'i':
if (!janet_vm.fiber->env) {
janet_vm.fiber->env = janet_table(0);
@@ -575,7 +588,9 @@ JANET_CORE_FN(cfun_fiber_status,
"* :error - the fiber has errored out\n"
"* :debug - the fiber is suspended in debug mode\n"
"* :pending - the fiber has been yielded\n"
"* :user(0-9) - the fiber is suspended by a user signal\n"
"* :user(0-7) - the fiber is suspended by a user signal\n"
"* :interrupted - the fiber was interrupted\n"
"* :suspended - the fiber is waiting to be resumed by the scheduler\n"
"* :alive - the fiber is currently running and cannot be resumed\n"
"* :new - the fiber has just been created and not yet run") {
janet_fixarity(argc, 1);
@@ -625,11 +640,7 @@ JANET_CORE_FN(cfun_fiber_setmaxstack,
return argv[0];
}
JANET_CORE_FN(cfun_fiber_can_resume,
"(fiber/can-resume? fiber)",
"Check if a fiber is finished and cannot be resumed.") {
janet_fixarity(argc, 1);
JanetFiber *fiber = janet_getfiber(argv, 0);
int janet_fiber_can_resume(JanetFiber *fiber) {
JanetFiberStatus s = janet_fiber_status(fiber);
int isFinished = s == JANET_STATUS_DEAD ||
s == JANET_STATUS_ERROR ||
@@ -638,7 +649,15 @@ JANET_CORE_FN(cfun_fiber_can_resume,
s == JANET_STATUS_USER2 ||
s == JANET_STATUS_USER3 ||
s == JANET_STATUS_USER4;
return janet_wrap_boolean(!isFinished);
return !isFinished;
}
JANET_CORE_FN(cfun_fiber_can_resume,
"(fiber/can-resume? fiber)",
"Check if a fiber is finished and cannot be resumed.") {
janet_fixarity(argc, 1);
JanetFiber *fiber = janet_getfiber(argv, 0);
return janet_wrap_boolean(janet_fiber_can_resume(fiber));
}
JANET_CORE_FN(cfun_fiber_last_value,

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -209,6 +209,12 @@ static void janet_mark_funcdef(JanetFuncDef *def) {
janet_mark_string(def->source);
if (def->name)
janet_mark_string(def->name);
if (def->symbolmap) {
for (int i = 0; i < def->symbolmap_length; i++) {
janet_mark_string(def->symbolmap[i].symbol);
}
}
}
static void janet_mark_function(JanetFunction *func) {
@@ -314,6 +320,7 @@ static void janet_deinit_block(JanetGCObject *mem) {
janet_free(def->bytecode);
janet_free(def->sourcemap);
janet_free(def->closure_bitset);
janet_free(def->symbolmap);
}
break;
}

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose & contributors
* Copyright (c) 2023 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
@@ -138,7 +138,7 @@ int64_t janet_unwrap_s64(Janet x) {
break;
}
}
janet_panicf("bad s64 initializer: %t", x);
janet_panicf("can not convert %t %q to 64 bit signed integer", x, x);
return 0;
}
@@ -169,7 +169,7 @@ uint64_t janet_unwrap_u64(Janet x) {
break;
}
}
janet_panicf("bad u64 initializer: %t", x);
janet_panicf("can not convert %t %q to a 64 bit unsigned integer", x, x);
return 0;
}
@@ -502,6 +502,18 @@ 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) {
janet_fixarity(argc, 2);
int64_t *box = janet_abstract(&janet_s64_type, sizeof(int64_t));
int64_t op2 = janet_unwrap_s64(argv[0]);
int64_t op1 = janet_unwrap_s64(argv[1]);
int64_t x = op1 % op2;
*box = (op1 > 0)
? ((op2 > 0) ? x : (0 == x ? x : x + op2))
: ((op2 > 0) ? (0 == x ? x : x + op2) : x);
return janet_wrap_abstract(box);
}
OPMETHOD(int64_t, s64, add, +)
OPMETHOD(int64_t, s64, sub, -)
OPMETHODINVERT(int64_t, s64, subi, -)
@@ -509,6 +521,7 @@ OPMETHOD(int64_t, s64, mul, *)
DIVMETHOD_SIGNED(int64_t, s64, div, /)
DIVMETHOD_SIGNED(int64_t, s64, rem, %)
DIVMETHODINVERT_SIGNED(int64_t, s64, divi, /)
DIVMETHODINVERT_SIGNED(int64_t, s64, remi, %)
OPMETHOD(int64_t, s64, and, &)
OPMETHOD(int64_t, s64, or, |)
OPMETHOD(int64_t, s64, xor, ^)
@@ -521,6 +534,7 @@ OPMETHOD(uint64_t, u64, mul, *)
DIVMETHOD(uint64_t, u64, div, /)
DIVMETHOD(uint64_t, u64, mod, %)
DIVMETHODINVERT(uint64_t, u64, divi, /)
DIVMETHODINVERT(uint64_t, u64, modi, %)
OPMETHOD(uint64_t, u64, and, &)
OPMETHOD(uint64_t, u64, or, |)
OPMETHOD(uint64_t, u64, xor, ^)
@@ -532,7 +546,6 @@ OPMETHOD(uint64_t, u64, rshift, >>)
#undef DIVMETHOD_SIGNED
#undef COMPMETHOD
static JanetMethod it_s64_methods[] = {
{"+", cfun_it_s64_add},
{"r+", cfun_it_s64_add},
@@ -543,9 +556,9 @@ static JanetMethod it_s64_methods[] = {
{"/", cfun_it_s64_div},
{"r/", cfun_it_s64_divi},
{"mod", cfun_it_s64_mod},
{"rmod", cfun_it_s64_mod},
{"rmod", cfun_it_s64_modi},
{"%", cfun_it_s64_rem},
{"r%", cfun_it_s64_rem},
{"r%", cfun_it_s64_remi},
{"&", cfun_it_s64_and},
{"r&", cfun_it_s64_and},
{"|", cfun_it_s64_or},
@@ -555,7 +568,6 @@ static JanetMethod it_s64_methods[] = {
{"<<", cfun_it_s64_lshift},
{">>", cfun_it_s64_rshift},
{"compare", cfun_it_s64_compare},
{NULL, NULL}
};
@@ -569,9 +581,9 @@ static JanetMethod it_u64_methods[] = {
{"/", cfun_it_u64_div},
{"r/", cfun_it_u64_divi},
{"mod", cfun_it_u64_mod},
{"rmod", cfun_it_u64_mod},
{"rmod", cfun_it_u64_modi},
{"%", cfun_it_u64_mod},
{"r%", cfun_it_u64_mod},
{"r%", cfun_it_u64_modi},
{"&", cfun_it_u64_and},
{"r&", cfun_it_u64_and},
{"|", cfun_it_u64_or},
@@ -581,7 +593,6 @@ static JanetMethod it_u64_methods[] = {
{"<<", cfun_it_u64_lshift},
{">>", cfun_it_u64_rshift},
{"compare", cfun_it_u64_compare},
{NULL, NULL}
};

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -69,12 +69,15 @@ static int32_t checkflags(const uint8_t *str) {
break;
case 'w':
flags |= JANET_FILE_WRITE;
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
break;
case 'a':
flags |= JANET_FILE_APPEND;
janet_sandbox_assert(JANET_SANDBOX_FS);
break;
case 'r':
flags |= JANET_FILE_READ;
janet_sandbox_assert(JANET_SANDBOX_FS_READ);
break;
}
for (i = 1; i < len; i++) {
@@ -84,6 +87,7 @@ static int32_t checkflags(const uint8_t *str) {
break;
case '+':
if (flags & JANET_FILE_UPDATE) return -1;
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
flags |= JANET_FILE_UPDATE;
break;
case 'b':
@@ -116,6 +120,7 @@ JANET_CORE_FN(cfun_io_temp,
"(file/temp)",
"Open an anonymous temporary file that is removed on close. "
"Raises an error on failure.") {
janet_sandbox_assert(JANET_SANDBOX_FS_TEMP);
(void)argv;
janet_fixarity(argc, 0);
// XXX use mkostemp when we can to avoid CLOEXEC race.
@@ -148,6 +153,7 @@ JANET_CORE_FN(cfun_io_fopen,
flags = checkflags(fmode);
} else {
fmode = (const uint8_t *)"r";
janet_sandbox_assert(JANET_SANDBOX_FS_READ);
flags = JANET_FILE_READ;
}
FILE *f = fopen((const char *)fname, (const char *)fmode);
@@ -243,6 +249,13 @@ JANET_CORE_FN(cfun_io_fwrite,
return argv[0];
}
static void io_assert_writeable(JanetFile *iof) {
if (iof->flags & JANET_FILE_CLOSED)
janet_panic("file is closed");
if (!(iof->flags & (JANET_FILE_WRITE | JANET_FILE_APPEND | JANET_FILE_UPDATE)))
janet_panic("file is not writeable");
}
/* Flush the bytes in the file */
JANET_CORE_FN(cfun_io_fflush,
"(file/flush f)",
@@ -250,10 +263,7 @@ JANET_CORE_FN(cfun_io_fflush,
"buffered for efficiency reasons. Returns the file handle.") {
janet_fixarity(argc, 1);
JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type);
if (iof->flags & JANET_FILE_CLOSED)
janet_panic("file is closed");
if (!(iof->flags & (JANET_FILE_WRITE | JANET_FILE_APPEND | JANET_FILE_UPDATE)))
janet_panic("file is not writeable");
io_assert_writeable(iof);
if (fflush(iof->file))
janet_panic("could not flush file");
return argv[0];
@@ -269,6 +279,7 @@ int janet_file_close(JanetFile *file) {
if (!(file->flags & (JANET_FILE_NOT_CLOSEABLE | JANET_FILE_CLOSED))) {
ret = fclose(file->file);
file->flags |= JANET_FILE_CLOSED;
file->file = NULL; /* NULL derefence is easier to debug then other problems */
return ret;
}
return 0;
@@ -337,11 +348,24 @@ JANET_CORE_FN(cfun_io_fseek,
return argv[0];
}
JANET_CORE_FN(cfun_io_ftell,
"(file/tell f)",
"Get the current value of the file position for file `f`.") {
janet_fixarity(argc, 1);
JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type);
if (iof->flags & JANET_FILE_CLOSED)
janet_panic("file is closed");
long pos = ftell(iof->file);
if (pos == -1) janet_panic("error getting position in file");
return janet_wrap_number((double)pos);
}
static JanetMethod io_file_methods[] = {
{"close", cfun_io_fclose},
{"flush", cfun_io_fflush},
{"read", cfun_io_fread},
{"seek", cfun_io_fseek},
{"tell", cfun_io_ftell},
{"write", cfun_io_fwrite},
{NULL, NULL}
};
@@ -449,6 +473,7 @@ static Janet cfun_io_print_impl_x(int32_t argc, Janet *argv, int newline,
if (janet_abstract_type(abstract) != &janet_file_type)
return janet_wrap_nil();
JanetFile *iofile = abstract;
io_assert_writeable(iofile);
f = iofile->file;
break;
}
@@ -479,7 +504,6 @@ static Janet cfun_io_print_impl_x(int32_t argc, Janet *argv, int newline,
return janet_wrap_nil();
}
static Janet cfun_io_print_impl(int32_t argc, Janet *argv,
int newline, const char *name, FILE *dflt_file) {
Janet x = janet_dyn(name);
@@ -564,6 +588,10 @@ static Janet cfun_io_printf_impl_x(int32_t argc, Janet *argv, int newline,
if (janet_abstract_type(abstract) != &janet_file_type)
return janet_wrap_nil();
JanetFile *iofile = abstract;
if (iofile->flags & JANET_FILE_CLOSED) {
janet_panic("cannot print to closed file");
}
io_assert_writeable(iofile);
f = iofile->file;
break;
}
@@ -688,6 +716,7 @@ void janet_dynprintf(const char *name, FILE *dflt_file, const char *format, ...)
if (janet_abstract_type(abstract) != &janet_file_type)
break;
JanetFile *iofile = abstract;
io_assert_writeable(iofile);
f = iofile->file;
}
fwrite(buffer.data, buffer.count, 1, f);
@@ -718,17 +747,17 @@ JanetFile *janet_getjfile(const Janet *argv, int32_t n) {
return janet_getabstract(argv, n, &janet_file_type);
}
FILE *janet_getfile(const Janet *argv, int32_t n, int *flags) {
FILE *janet_getfile(const Janet *argv, int32_t n, int32_t *flags) {
JanetFile *iof = janet_getabstract(argv, n, &janet_file_type);
if (NULL != flags) *flags = iof->flags;
return iof->file;
}
JanetFile *janet_makejfile(FILE *f, int flags) {
JanetFile *janet_makejfile(FILE *f, int32_t flags) {
return makef(f, flags);
}
Janet janet_makefile(FILE *f, int flags) {
Janet janet_makefile(FILE *f, int32_t flags) {
return janet_wrap_abstract(makef(f, flags));
}
@@ -736,7 +765,7 @@ JanetAbstract janet_checkfile(Janet j) {
return janet_checkabstract(j, &janet_file_type);
}
FILE *janet_unwrapfile(Janet j, int *flags) {
FILE *janet_unwrapfile(Janet j, int32_t *flags) {
JanetFile *iof = janet_unwrap_abstract(j);
if (NULL != flags) *flags = iof->flags;
return iof->file;
@@ -766,6 +795,7 @@ void janet_lib_io(JanetTable *env) {
JANET_CORE_REG("file/write", cfun_io_fwrite),
JANET_CORE_REG("file/flush", cfun_io_fflush),
JANET_CORE_REG("file/seek", cfun_io_fseek),
JANET_CORE_REG("file/tell", cfun_io_ftell),
JANET_REG_END
};
janet_core_cfuns_ext(env, NULL, io_cfuns);

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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,8 @@ enum {
LB_UNSAFE_POINTER, /* 222 */
LB_STRUCT_PROTO, /* 223 */
#ifdef JANET_EV
LB_THREADED_ABSTRACT/* 224 */
LB_THREADED_ABSTRACT, /* 224 */
LB_POINTER_BUFFER, /* 224 */
#endif
} LeadBytes;
@@ -153,6 +154,10 @@ static void pushbytes(MarshalState *st, const uint8_t *bytes, int32_t len) {
janet_buffer_push_bytes(st->buf, bytes, len);
}
static void pushpointer(MarshalState *st, void *ptr) {
janet_buffer_push_bytes(st->buf, (const uint8_t *) &ptr, sizeof(ptr));
}
/* Marshal a size_t onto the buffer */
static void push64(MarshalState *st, uint64_t x) {
if (x <= 0xF0) {
@@ -252,6 +257,8 @@ static void marshal_one_def(MarshalState *st, JanetFuncDef *def, int flags) {
pushint(st, def->environments_length);
if (def->flags & JANET_FUNCDEF_FLAG_HASDEFS)
pushint(st, def->defs_length);
if (def->flags & JANET_FUNCDEF_FLAG_HASSYMBOLMAP)
pushint(st, def->symbolmap_length);
if (def->flags & JANET_FUNCDEF_FLAG_HASNAME)
marshal_one(st, janet_wrap_string(def->name), flags);
if (def->flags & JANET_FUNCDEF_FLAG_HASSOURCE)
@@ -261,6 +268,14 @@ static void marshal_one_def(MarshalState *st, JanetFuncDef *def, int flags) {
for (int32_t i = 0; i < def->constants_length; i++)
marshal_one(st, def->constants[i], flags);
/* Marshal symbol map, if needed */
for (int32_t i = 0; i < def->symbolmap_length; i++) {
pushint(st, (int32_t) def->symbolmap[i].birth_pc);
pushint(st, (int32_t) def->symbolmap[i].death_pc);
pushint(st, (int32_t) def->symbolmap[i].slot_index);
marshal_one(st, janet_wrap_symbol(def->symbolmap[i].symbol), flags);
}
/* marshal the bytecode */
janet_marshal_u32s(st, def->bytecode, def->bytecode_length);
@@ -270,7 +285,7 @@ static void marshal_one_def(MarshalState *st, JanetFuncDef *def, int flags) {
/* marshal the sub funcdefs if needed */
for (int32_t i = 0; i < def->defs_length; i++)
marshal_one_def(st, def->defs[i], flags);
marshal_one_def(st, def->defs[i], flags + 1);
/* marshal source maps if needed */
if (def->flags & JANET_FUNCDEF_FLAG_HASSOURCEMAP) {
@@ -347,6 +362,15 @@ void janet_marshal_int(JanetMarshalContext *ctx, int32_t value) {
pushint(st, value);
}
/* Only use in unsafe - don't marshal pointers otherwise */
void janet_marshal_ptr(JanetMarshalContext *ctx, const void *ptr) {
#ifdef JANET_32
janet_marshal_int(ctx, (intptr_t) ptr);
#else
janet_marshal_int64(ctx, (intptr_t) ptr);
#endif
}
void janet_marshal_byte(JanetMarshalContext *ctx, uint8_t value) {
MarshalState *st = (MarshalState *)(ctx->m_state);
pushbyte(st, value);
@@ -501,6 +525,16 @@ static void marshal_one(MarshalState *st, Janet x, int flags) {
JanetBuffer *buffer = janet_unwrap_buffer(x);
/* Record reference */
MARK_SEEN();
#ifdef JANET_EV
if ((flags & JANET_MARSHAL_UNSAFE) &&
(buffer->gc.flags & JANET_BUFFER_FLAG_NO_REALLOC)) {
pushbyte(st, LB_POINTER_BUFFER);
pushint(st, buffer->count);
pushint(st, buffer->capacity);
pushpointer(st, buffer->data);
return;
}
#endif
pushbyte(st, LB_BUFFER);
pushint(st, buffer->count);
pushbytes(st, buffer->data, buffer->count);
@@ -596,8 +630,7 @@ static void marshal_one(MarshalState *st, Janet x, int flags) {
if (!(flags & JANET_MARSHAL_UNSAFE)) goto no_registry;
MARK_SEEN();
pushbyte(st, LB_UNSAFE_POINTER);
void *ptr = janet_unwrap_pointer(x);
pushbytes(st, (uint8_t *) &ptr, sizeof(void *));
pushpointer(st, janet_unwrap_pointer(x));
return;
}
no_registry:
@@ -824,6 +857,8 @@ static const uint8_t *unmarshal_one_def(
def->constants = NULL;
def->bytecode = NULL;
def->sourcemap = NULL;
def->symbolmap = NULL;
def->symbolmap_length = 0;
janet_v_push(st->lookup_defs, def);
/* Set default lengths to zero */
@@ -831,6 +866,7 @@ static const uint8_t *unmarshal_one_def(
int32_t constants_length = 0;
int32_t environments_length = 0;
int32_t defs_length = 0;
int32_t symbolmap_length = 0;
/* Read flags and other fixed values */
def->flags = readint(st, &data);
@@ -846,6 +882,8 @@ static const uint8_t *unmarshal_one_def(
environments_length = readnat(st, &data);
if (def->flags & JANET_FUNCDEF_FLAG_HASDEFS)
defs_length = readnat(st, &data);
if (def->flags & JANET_FUNCDEF_FLAG_HASSYMBOLMAP)
symbolmap_length = readnat(st, &data);
/* Check name and source (optional) */
if (def->flags & JANET_FUNCDEF_FLAG_HASNAME) {
@@ -874,6 +912,26 @@ static const uint8_t *unmarshal_one_def(
}
def->constants_length = constants_length;
/* Unmarshal symbol map, if needed */
if (def->flags & JANET_FUNCDEF_FLAG_HASSYMBOLMAP) {
size_t size = sizeof(JanetSymbolMap) * symbolmap_length;
def->symbolmap = janet_malloc(size);
if (def->symbolmap == NULL) {
JANET_OUT_OF_MEMORY;
}
for (int32_t i = 0; i < symbolmap_length; i++) {
def->symbolmap[i].birth_pc = (uint32_t) readint(st, &data);
def->symbolmap[i].death_pc = (uint32_t) readint(st, &data);
def->symbolmap[i].slot_index = (uint32_t) readint(st, &data);
Janet value;
data = unmarshal_one(st, data, &value, flags + 1);
if (!janet_checktype(value, JANET_SYMBOL))
janet_panic("expected symbol in symbol map");
def->symbolmap[i].symbol = janet_unwrap_symbol(value);
}
def->symbolmap_length = (uint32_t) symbolmap_length;
}
/* Unmarshal bytecode */
def->bytecode = janet_malloc(sizeof(uint32_t) * bytecode_length);
if (!def->bytecode) {
@@ -1116,6 +1174,15 @@ int64_t janet_unmarshal_int64(JanetMarshalContext *ctx) {
return read64(st, &(ctx->data));
}
void *janet_unmarshal_ptr(JanetMarshalContext *ctx) {
UnmarshalState *st = (UnmarshalState *)(ctx->u_state);
#ifdef JANET_32
return (void *) ((intptr_t) readint(st, &(ctx->data)));
#else
return (void *) ((intptr_t) read64(st, &(ctx->data)));
#endif
}
uint8_t janet_unmarshal_byte(JanetMarshalContext *ctx) {
UnmarshalState *st = (UnmarshalState *)(ctx->u_state);
MARSH_EOS(st, ctx->data);
@@ -1380,6 +1447,29 @@ static const uint8_t *unmarshal_one(
janet_v_push(st->lookup, *out);
return data;
}
#ifdef JANET_EV
case LB_POINTER_BUFFER: {
data++;
int32_t count = readnat(st, &data);
int32_t capacity = readnat(st, &data);
MARSH_EOS(st, data + sizeof(void *));
union {
void *ptr;
uint8_t bytes[sizeof(void *)];
} u;
if (!(flags & JANET_MARSHAL_UNSAFE)) {
janet_panicf("unsafe flag not given, "
"will not unmarshal raw pointer at index %d",
(int)(data - st->start));
}
memcpy(u.bytes, data, sizeof(void *));
data += sizeof(void *);
JanetBuffer *buffer = janet_pointer_buffer_unsafe(u.ptr, capacity, count);
*out = janet_wrap_buffer(buffer);
janet_v_push(st->lookup, *out);
return data;
}
#endif
case LB_UNSAFE_CFUNCTION: {
MARSH_EOS(st, data + sizeof(JanetCFunction));
data++;

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -150,8 +150,8 @@ JANET_CORE_FN(cfun_rng_uniform,
JANET_CORE_FN(cfun_rng_int,
"(math/rng-int rng &opt max)",
"Extract a random random integer in the range [0, max] from the RNG. If "
"no max is given, the default is 2^31 - 1."
"Extract a random integer in the range [0, max) for max > 0 from the RNG. "
"If max is 0, return 0. If no max is given, the default is 2^31 - 1."
) {
janet_arity(argc, 1, 2);
JanetRNG *rng = janet_getabstract(argv, 0, &janet_rng_type);
@@ -254,43 +254,45 @@ JANET_CORE_FN(janet_srand,
return janet_wrap_nil();
}
#define JANET_DEFINE_MATHOP(name, fop, doc)\
JANET_CORE_FN(janet_##name, "(math/" #name " x)", doc) {\
#define JANET_DEFINE_NAMED_MATHOP(janet_name, fop, doc)\
JANET_CORE_FN(janet_##fop, "(math/" janet_name " x)", doc) {\
janet_fixarity(argc, 1); \
double x = janet_getnumber(argv, 0); \
return janet_wrap_number(fop(x)); \
}
JANET_DEFINE_MATHOP(acos, acos, "Returns the arccosine of x.")
JANET_DEFINE_MATHOP(asin, asin, "Returns the arcsin of x.")
JANET_DEFINE_MATHOP(atan, atan, "Returns the arctangent of x.")
JANET_DEFINE_MATHOP(cos, cos, "Returns the cosine of x.")
JANET_DEFINE_MATHOP(cosh, cosh, "Returns the hyperbolic cosine of x.")
JANET_DEFINE_MATHOP(acosh, acosh, "Returns the hyperbolic arccosine of x.")
JANET_DEFINE_MATHOP(sin, sin, "Returns the sine of x.")
JANET_DEFINE_MATHOP(sinh, sinh, "Returns the hyperbolic sine of x.")
JANET_DEFINE_MATHOP(asinh, asinh, "Returns the hypberbolic arcsine of x.")
JANET_DEFINE_MATHOP(tan, tan, "Returns the tangent of x.")
JANET_DEFINE_MATHOP(tanh, tanh, "Returns the hyperbolic tangent of x.")
JANET_DEFINE_MATHOP(atanh, atanh, "Returns the hyperbolic arctangent of x.")
JANET_DEFINE_MATHOP(exp, exp, "Returns e to the power of x.")
JANET_DEFINE_MATHOP(exp2, exp2, "Returns 2 to the power of x.")
JANET_DEFINE_MATHOP(expm1, expm1, "Returns e to the power of x minus 1.")
JANET_DEFINE_MATHOP(log, log, "Returns the natural logarithm of x.")
JANET_DEFINE_MATHOP(log10, log10, "Returns the log base 10 of x.")
JANET_DEFINE_MATHOP(log2, log2, "Returns the log base 2 of x.")
JANET_DEFINE_MATHOP(sqrt, sqrt, "Returns the square root of x.")
JANET_DEFINE_MATHOP(cbrt, cbrt, "Returns the cube root of x.")
JANET_DEFINE_MATHOP(ceil, ceil, "Returns the smallest integer value number that is not less than x.")
JANET_DEFINE_MATHOP(fabs, fabs, "Return the absolute value of x.")
JANET_DEFINE_MATHOP(floor, floor, "Returns the largest integer value number that is not greater than x.")
JANET_DEFINE_MATHOP(trunc, trunc, "Returns the integer between x and 0 nearest to x.")
JANET_DEFINE_MATHOP(round, round, "Returns the integer nearest to x.")
JANET_DEFINE_MATHOP(gamma, tgamma, "Returns gamma(x).")
JANET_DEFINE_MATHOP(lgamma, lgamma, "Returns log-gamma(x).")
JANET_DEFINE_MATHOP(log1p, log1p, "Returns (log base e of x) + 1 more accurately than (+ (math/log x) 1)")
JANET_DEFINE_MATHOP(erf, erf, "Returns the error function of x.")
JANET_DEFINE_MATHOP(erfc, erfc, "Returns the complementary error function of x.")
#define JANET_DEFINE_MATHOP(fop, doc) JANET_DEFINE_NAMED_MATHOP(#fop, fop, doc)
JANET_DEFINE_MATHOP(acos, "Returns the arccosine of x.")
JANET_DEFINE_MATHOP(asin, "Returns the arcsin of x.")
JANET_DEFINE_MATHOP(atan, "Returns the arctangent of x.")
JANET_DEFINE_MATHOP(cos, "Returns the cosine of x.")
JANET_DEFINE_MATHOP(cosh, "Returns the hyperbolic cosine of x.")
JANET_DEFINE_MATHOP(acosh, "Returns the hyperbolic arccosine of x.")
JANET_DEFINE_MATHOP(sin, "Returns the sine of x.")
JANET_DEFINE_MATHOP(sinh, "Returns the hyperbolic sine of x.")
JANET_DEFINE_MATHOP(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(expm1, "Returns e to the power of x minus 1.")
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) {\
@@ -303,7 +305,7 @@ 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.")
JANET_DEFINE_MATH2OP(nextafter, nextafter, "(math/next x y)", "Returns the next representable floating point vaue after x in the direction of y.")
JANET_DEFINE_MATH2OP(nextafter, nextafter, "(math/next x y)", "Returns the next representable floating point value after x in the direction of y.")
JANET_CORE_FN(janet_not, "(not x)", "Returns the boolean inverse of x.") {
janet_fixarity(argc, 1);
@@ -315,7 +317,7 @@ static double janet_gcd(double x, double y) {
#ifdef NAN
return NAN;
#else
return 0.0 \ 0.0;
return 0.0 / 0.0;
#endif
}
if (isinf(x) || isinf(y)) return INFINITY;
@@ -383,7 +385,7 @@ 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_gamma),
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),

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose and contributors.
* Copyright (c) 2023 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
@@ -34,9 +34,11 @@
#include <windows.h>
#include <ws2tcpip.h>
#include <mswsock.h>
#ifdef JANET_MSVC
#pragma comment (lib, "Ws2_32.lib")
#pragma comment (lib, "Mswsock.lib")
#pragma comment (lib, "Advapi32.lib")
#endif
#else
#include <arpa/inet.h>
#include <unistd.h>
@@ -173,7 +175,6 @@ JanetAsyncStatus net_machine_accept(JanetListenerState *s, JanetAsyncEvent event
JANET_NO_RETURN static void janet_sched_accept(JanetStream *stream, JanetFunction *fun) {
Janet err;
SOCKET lsock = (SOCKET) stream->handle;
JanetListenerState *s = janet_listen(stream, net_machine_accept, JANET_ASYNC_LISTEN_READ, sizeof(NetStateAccept), NULL);
NetStateAccept *state = (NetStateAccept *)s;
memset(&state->overlapped, 0, sizeof(WSAOVERLAPPED));
@@ -255,7 +256,6 @@ JANET_NO_RETURN static void janet_sched_accept(JanetStream *stream, JanetFunctio
janet_await();
}
#endif
/* Adress info */
@@ -333,6 +333,7 @@ JANET_CORE_FN(cfun_net_sockaddr,
"given in the port argument. On Linux, abstract "
"unix domain sockets are specified with a leading '@' character in port. If `multi` is truthy, will "
"return all address that match in an array instead of just the first.") {
janet_sandbox_assert(JANET_SANDBOX_NET_CONNECT); /* connect OR listen */
janet_arity(argc, 2, 4);
int socktype = janet_get_sockettype(argv, argc, 2);
int is_unix = 0;
@@ -378,6 +379,7 @@ JANET_CORE_FN(cfun_net_connect,
"to specify a connection type, either :stream or :datagram. The default is :stream. "
"Bindhost is an optional string to select from what address to make the outgoing "
"connection, with the default being the same as using the OS's preferred address. ") {
janet_sandbox_assert(JANET_SANDBOX_NET_CONNECT);
janet_arity(argc, 2, 5);
/* Check arguments */
@@ -414,7 +416,6 @@ JANET_CORE_FN(cfun_net_connect,
}
}
/* Create socket */
JSock sock = JSOCKDEFAULT;
void *addr = NULL;
@@ -457,7 +458,7 @@ JANET_CORE_FN(cfun_net_connect,
if (binding) {
struct addrinfo *rp = NULL;
int did_bind = 0;
for (rp = ai; rp != NULL; rp = rp->ai_next) {
for (rp = binding; rp != NULL; rp = rp->ai_next) {
if (bind(sock, rp->ai_addr, (int) rp->ai_addrlen) == 0) {
did_bind = 1;
break;
@@ -474,14 +475,20 @@ JANET_CORE_FN(cfun_net_connect,
}
}
/* Wrap socket in abstract type JanetStream */
JanetStream *stream = make_stream(sock, JANET_STREAM_READABLE | JANET_STREAM_WRITABLE);
/* 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);
Janet lasterr = janet_ev_lasterr();
int err = WSAGetLastError();
freeaddrinfo(ai);
#else
int status = connect(sock, addr, addrlen);
Janet lasterr = janet_ev_lasterr();
int err = errno;
if (is_unix) {
janet_free(ai);
} else {
@@ -489,17 +496,22 @@ JANET_CORE_FN(cfun_net_connect,
}
#endif
if (status == -1) {
JSOCKCLOSE(sock);
janet_panicf("could not connect socket: %V", lasterr);
if (status != 0) {
#ifdef JANET_WINDOWS
if (err != WSAEWOULDBLOCK) {
#else
if (err != EINPROGRESS) {
#endif
JSOCKCLOSE(sock);
Janet lasterr = janet_ev_lasterr();
janet_panicf("could not connect socket: %V", lasterr);
}
}
/* Set up the socket for non-blocking IO after connect - TODO - non-blocking connect? */
janet_net_socknoblock(sock);
/* Handle the connect() result in the event loop*/
janet_ev_connect(stream, MSG_NOSIGNAL);
/* Wrap socket in abstract type JanetStream */
JanetStream *stream = make_stream(sock, JANET_STREAM_READABLE | JANET_STREAM_WRITABLE);
return janet_wrap_abstract(stream);
janet_await();
}
static const char *serverify_socket(JSock sfd) {
@@ -572,6 +584,7 @@ JANET_CORE_FN(cfun_net_listen,
"The type parameter specifies the type of network connection, either "
"a :stream (usually tcp), or :datagram (usually udp). If not specified, the default is "
":stream. The host and port arguments are the same as in net/address.") {
janet_sandbox_assert(JANET_SANDBOX_NET_LISTEN);
janet_arity(argc, 2, 3);
/* Get host, port, and handler*/
@@ -706,7 +719,7 @@ JANET_CORE_FN(cfun_net_getsockname,
if (getsockname((JSock)js->handle, (struct sockaddr *) &ss, &slen)) {
janet_panicf("Failed to get localname on %v: %V", argv[0], janet_ev_lasterr());
}
janet_assert(slen <= sizeof(ss), "socket address truncated");
janet_assert(slen <= (socklen_t) sizeof(ss), "socket address truncated");
return janet_so_getname(&ss);
}
@@ -722,13 +735,13 @@ JANET_CORE_FN(cfun_net_getpeername,
if (getpeername((JSock)js->handle, (struct sockaddr *)&ss, &slen)) {
janet_panicf("Failed to get peername on %v: %V", argv[0], janet_ev_lasterr());
}
janet_assert(slen <= sizeof(ss), "socket address truncated");
janet_assert(slen <= (socklen_t) sizeof(ss), "socket address truncated");
return janet_so_getname(&ss);
}
JANET_CORE_FN(cfun_net_address_unpack,
"(net/address-unpack address)",
"Given an address returned by net/adress, return a host, port pair. Unix domain sockets "
"Given an address returned by net/address, return a host, port pair. Unix domain sockets "
"will have only the path in the returned tuple.") {
janet_fixarity(argc, 1);
struct sockaddr *sa = janet_getabstract(argv, 0, &janet_address_type);
@@ -798,7 +811,7 @@ JANET_CORE_FN(cfun_stream_chunk,
}
JANET_CORE_FN(cfun_stream_recv_from,
"(net/recv-from stream nbytes buf &opt timoeut)",
"(net/recv-from stream nbytes buf &opt timeout)",
"Receives data from a server stream and puts it into a buffer. Returns the socket-address the "
"packet came from. Takes an optional timeout in seconds, after which will return nil.") {
janet_arity(argc, 3, 4);
@@ -868,6 +881,98 @@ JANET_CORE_FN(cfun_stream_flush,
return argv[0];
}
struct sockopt_type {
const char *name;
int level;
int optname;
enum JanetType type;
};
/* List of supported socket options; The type JANET_POINTER is used
* for options that require special handling depending on the type. */
static const struct sockopt_type sockopt_type_list[] = {
{ "so-broadcast", SOL_SOCKET, SO_BROADCAST, JANET_BOOLEAN },
{ "so-reuseaddr", SOL_SOCKET, SO_REUSEADDR, JANET_BOOLEAN },
{ "so-keepalive", SOL_SOCKET, SO_KEEPALIVE, JANET_BOOLEAN },
{ "ip-multicast-ttl", IPPROTO_IP, IP_MULTICAST_TTL, JANET_NUMBER },
{ "ip-add-membership", IPPROTO_IP, IP_ADD_MEMBERSHIP, JANET_POINTER },
{ "ip-drop-membership", IPPROTO_IP, IP_DROP_MEMBERSHIP, JANET_POINTER },
{ "ipv6-join-group", IPPROTO_IPV6, IPV6_JOIN_GROUP, JANET_POINTER },
{ "ipv6-leave-group", IPPROTO_IPV6, IPV6_LEAVE_GROUP, JANET_POINTER },
{ NULL, 0, 0, JANET_POINTER }
};
JANET_CORE_FN(cfun_net_setsockopt,
"(net/setsockopt stream option value)",
"set socket options.\n"
"\n"
"supported options and associated value types:\n"
"- :so-broadcast boolean\n"
"- :so-reuseaddr boolean\n"
"- :so-keepalive boolean\n"
"- :ip-multicast-ttl number\n"
"- :ip-add-membership string\n"
"- :ip-drop-membership string\n"
"- :ipv6-join-group string\n"
"- :ipv6-leave-group string\n") {
janet_arity(argc, 3, 3);
JanetStream *stream = janet_getabstract(argv, 0, &janet_stream_type);
janet_stream_flags(stream, JANET_STREAM_SOCKET);
JanetKeyword optstr = janet_getkeyword(argv, 1);
const struct sockopt_type *st = sockopt_type_list;
while (st->name) {
if (janet_cstrcmp(optstr, st->name) == 0) {
break;
}
st++;
}
if (st->name == NULL) {
janet_panicf("unknown socket option %q", argv[1]);
}
union {
int v_int;
struct ip_mreq v_mreq;
struct ipv6_mreq v_mreq6;
} val;
void *optval = (void *)&val;
socklen_t optlen = 0;
if (st->type == JANET_BOOLEAN) {
val.v_int = janet_getboolean(argv, 2);
optlen = sizeof(val.v_int);
} else if (st->type == JANET_NUMBER) {
val.v_int = janet_getinteger(argv, 2);
optlen = sizeof(val.v_int);
} else if (st->optname == IP_ADD_MEMBERSHIP || st->optname == IP_DROP_MEMBERSHIP) {
const char *addr = janet_getcstring(argv, 2);
memset(&val.v_mreq, 0, sizeof val.v_mreq);
val.v_mreq.imr_interface.s_addr = htonl(INADDR_ANY);
inet_pton(AF_INET, addr, &val.v_mreq.imr_multiaddr.s_addr);
optlen = sizeof(val.v_mreq);
} else if (st->optname == IPV6_JOIN_GROUP || st->optname == IPV6_LEAVE_GROUP) {
const char *addr = janet_getcstring(argv, 2);
memset(&val.v_mreq6, 0, sizeof val.v_mreq6);
val.v_mreq6.ipv6mr_interface = 0;
inet_pton(AF_INET6, addr, &val.v_mreq6.ipv6mr_multiaddr);
optlen = sizeof(val.v_mreq6);
} else {
janet_panicf("invalid socket option type");
}
janet_assert(optlen != 0, "invalid socket option value");
int r = setsockopt((JSock) stream->handle, st->level, st->optname, optval, optlen);
if (r == -1) {
janet_panicf("setsockopt(%q): %s", argv[1], strerror(errno));
}
return janet_wrap_nil();
}
static const JanetMethod net_stream_methods[] = {
{"chunk", cfun_stream_chunk},
{"close", janet_cfun_stream_close},
@@ -882,6 +987,7 @@ static const JanetMethod net_stream_methods[] = {
{"evchunk", janet_cfun_stream_chunk},
{"evwrite", janet_cfun_stream_write},
{"shutdown", cfun_net_shutdown},
{"setsockopt", cfun_net_setsockopt},
{NULL, NULL}
};
@@ -906,6 +1012,7 @@ void janet_lib_net(JanetTable *env) {
JANET_CORE_REG("net/peername", cfun_net_getpeername),
JANET_CORE_REG("net/localname", cfun_net_getsockname),
JANET_CORE_REG("net/address-unpack", cfun_net_address_unpack),
JANET_CORE_REG("net/setsockopt", cfun_net_setsockopt),
JANET_REG_END
};
janet_core_cfuns_ext(env, NULL, net_cfuns);

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose and contributors.
* Copyright (c) 2023 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
@@ -118,18 +118,26 @@ JANET_CORE_FN(os_which,
"(os/which)",
"Check the current operating system. Returns one of:\n\n"
"* :windows\n\n"
"* :mingw\n\n"
"* :cygwin\n\n"
"* :macos\n\n"
"* :web - Web assembly (emscripten)\n\n"
"* :linux\n\n"
"* :freebsd\n\n"
"* :openbsd\n\n"
"* :netbsd\n\n"
"* :dragonfly\n\n"
"* :bsd\n\n"
"* :posix - A POSIX compatible system (default)\n\n"
"May also return a custom keyword specified at build time.") {
janet_fixarity(argc, 0);
(void) argv;
#if defined(JANET_OS_NAME)
return janet_ckeywordv(janet_stringify(JANET_OS_NAME));
#elif defined(JANET_MINGW)
return janet_ckeywordv("mingw");
#elif defined(JANET_CYGWIN)
return janet_ckeywordv("cygwin");
#elif defined(JANET_WINDOWS)
return janet_ckeywordv("windows");
#elif defined(JANET_APPLE)
@@ -144,6 +152,8 @@ JANET_CORE_FN(os_which,
return janet_ckeywordv("netbsd");
#elif defined(__OpenBSD__)
return janet_ckeywordv("openbsd");
#elif defined(__DragonFly__)
return janet_ckeywordv("dragonfly");
#elif defined(JANET_BSD)
return janet_ckeywordv("bsd");
#else
@@ -159,6 +169,8 @@ JANET_CORE_FN(os_arch,
"* :x64\n\n"
"* :arm\n\n"
"* :aarch64\n\n"
"* :riscv32\n\n"
"* :riscv64\n\n"
"* :sparc\n\n"
"* :wasm\n\n"
"* :unknown\n") {
@@ -177,6 +189,10 @@ JANET_CORE_FN(os_arch,
return janet_ckeywordv("aarch64");
#elif defined(_M_ARM) || defined(__arm__)
return janet_ckeywordv("arm");
#elif (defined(__riscv) && (__riscv_xlen == 64))
return janet_ckeywordv("riscv64");
#elif (defined(__riscv) && (__riscv_xlen == 32))
return janet_ckeywordv("riscv32");
#elif (defined(__sparc__))
return janet_ckeywordv("sparc");
#elif (defined(__ppc__))
@@ -188,6 +204,27 @@ JANET_CORE_FN(os_arch,
#endif
}
/* Detect the compiler used to build the interpreter */
JANET_CORE_FN(os_compiler,
"(os/compiler)",
"Get the compiler used to compile the interpreter. Returns one of:\n\n"
"* :gcc\n\n"
"* :clang\n\n"
"* :msvc\n\n"
"* :unknown\n\n") {
janet_fixarity(argc, 0);
(void) argv;
#if defined(_MSC_VER)
return janet_ckeywordv("msvc");
#elif defined(__clang__)
return janet_ckeywordv("clang");
#elif defined(__GNUC__)
return janet_ckeywordv("gcc");
#else
return janet_ckeywordv("unknown");
#endif
}
#undef janet_stringify1
#undef janet_stringify
@@ -209,6 +246,8 @@ JANET_CORE_FN(os_exit,
return janet_wrap_nil();
}
#ifndef JANET_REDUCED_OS
JANET_CORE_FN(os_cpu_count,
"(os/cpu-count &opt dflt)",
"Get an approximate number of CPUs available on for this process to use. If "
@@ -250,8 +289,6 @@ JANET_CORE_FN(os_cpu_count,
#endif
}
#ifndef JANET_REDUCED_OS
#ifndef JANET_NO_PROCESSES
/* Get env for os_execute */
@@ -444,7 +481,9 @@ typedef struct {
static JanetEVGenericMessage janet_proc_wait_subr(JanetEVGenericMessage args) {
JanetProc *proc = (JanetProc *) args.argp;
WaitForSingleObject(proc->pHandle, INFINITE);
GetExitCodeProcess(proc->pHandle, &args.tag);
DWORD exitcode = 0;
GetExitCodeProcess(proc->pHandle, &exitcode);
args.tag = (int32_t) exitcode;
return args;
}
@@ -584,12 +623,99 @@ JANET_CORE_FN(os_proc_wait,
#endif
}
struct keyword_signal {
const char *keyword;
int signal;
};
#ifndef JANET_WINDOWS
static const struct keyword_signal signal_keywords[] = {
#ifdef SIGKILL
{"kill", SIGKILL},
#endif
{"int", SIGINT},
{"abrt", SIGABRT},
{"fpe", SIGFPE},
{"ill", SIGILL},
{"segv", SIGSEGV},
#ifdef SIGTERM
{"term", SIGTERM},
#endif
#ifdef SIGARLM
{"alrm", SIGALRM},
#endif
#ifdef SIGHUP
{"hup", SIGHUP},
#endif
#ifdef SIGPIPE
{"pipe", SIGPIPE},
#endif
#ifdef SIGQUIT
{"quit", SIGQUIT},
#endif
#ifdef SIGUSR1
{"usr1", SIGUSR1},
#endif
#ifdef SIGUSR2
{"usr2", SIGUSR2},
#endif
#ifdef SIGCHLD
{"chld", SIGCHLD},
#endif
#ifdef SIGCONT
{"cont", SIGCONT},
#endif
#ifdef SIGSTOP
{"stop", SIGSTOP},
#endif
#ifdef SIGTSTP
{"tstp", SIGTSTP},
#endif
#ifdef SIGTTIN
{"ttin", SIGTTIN},
#endif
#ifdef SIGTTOU
{"ttou", SIGTTOU},
#endif
#ifdef SIGBUS
{"bus", SIGBUS},
#endif
#ifdef SIGPOLL
{"poll", SIGPOLL},
#endif
#ifdef SIGPROF
{"prof", SIGPROF},
#endif
#ifdef SIGSYS
{"sys", SIGSYS},
#endif
#ifdef SIGTRAP
{"trap", SIGTRAP},
#endif
#ifdef SIGURG
{"urg", SIGURG},
#endif
#ifdef SIGVTALRM
{"vtlarm", SIGVTALRM},
#endif
#ifdef SIGXCPU
{"xcpu", SIGXCPU},
#endif
#ifdef SIGXFSZ
{"xfsz", SIGXFSZ},
#endif
{NULL, 0},
};
#endif
JANET_CORE_FN(os_proc_kill,
"(os/proc-kill proc &opt wait)",
"(os/proc-kill proc &opt wait signal)",
"Kill a subprocess by sending SIGKILL to it on posix systems, or by closing the process "
"handle on windows. If `wait` is truthy, will wait for the process to finish and "
"returns the exit code. Otherwise, returns `proc`.") {
janet_arity(argc, 1, 2);
"returns the exit code. Otherwise, returns `proc`. If signal is specified send it instead."
"Signal keywords are named after their C counterparts but in lowercase with the leading "
"`SIG` stripped. Signals are ignored on windows.") {
janet_arity(argc, 1, 3);
JanetProc *proc = janet_getabstract(argv, 0, &ProcAT);
if (proc->flags & JANET_PROC_WAITED) {
janet_panicf("cannot kill process that has already finished");
@@ -603,7 +729,22 @@ JANET_CORE_FN(os_proc_kill,
CloseHandle(proc->pHandle);
CloseHandle(proc->tHandle);
#else
int status = kill(proc->pid, SIGKILL);
int signal = -1;
if (argc == 3) {
JanetKeyword signal_kw = janet_getkeyword(argv, 2);
const struct keyword_signal *ptr = signal_keywords;
while (ptr->keyword) {
if (!janet_cstrcmp(signal_kw, ptr->keyword)) {
signal = ptr->signal;
break;
}
ptr++;
}
if (signal == -1) {
janet_panic("undefined signal");
}
}
int status = kill(proc->pid, signal == -1 ? SIGKILL : signal);
if (status) {
janet_panic(strerror(errno));
}
@@ -842,6 +983,7 @@ static JanetFile *get_stdio_for_handle(JanetHandle handle, void *orig, int iswri
#endif
static Janet os_execute_impl(int32_t argc, Janet *argv, int is_spawn) {
janet_sandbox_assert(JANET_SANDBOX_SUBPROCESS);
janet_arity(argc, 1, 3);
/* Get flags */
@@ -901,9 +1043,6 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, int is_spawn) {
janet_panic("failed to create pipes");
}
/* Result */
int status = 0;
#ifdef JANET_WINDOWS
HANDLE pHandle, tHandle;
@@ -936,7 +1075,6 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, int is_spawn) {
startupInfo.hStdInput = (HANDLE) _get_osfhandle(0);
}
if (pipe_out != JANET_HANDLE_NONE) {
startupInfo.hStdOutput = pipe_out;
} else if (new_out != JANET_HANDLE_NONE) {
@@ -982,6 +1120,9 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, int is_spawn) {
#else
/* Result */
int status = 0;
const char **child_argv = janet_smalloc(sizeof(char *) * ((size_t) exargs.len + 1));
for (int32_t i = 0; i < exargs.len; i++)
child_argv[i] = janet_getcstring(exargs.items, i);
@@ -1002,21 +1143,23 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, int is_spawn) {
if (pipe_in != JANET_HANDLE_NONE) {
posix_spawn_file_actions_adddup2(&actions, pipe_in, 0);
posix_spawn_file_actions_addclose(&actions, pipe_in);
} else if (new_in != JANET_HANDLE_NONE) {
} else if (new_in != JANET_HANDLE_NONE && new_in != 0) {
posix_spawn_file_actions_adddup2(&actions, new_in, 0);
posix_spawn_file_actions_addclose(&actions, new_in);
if (new_in != new_out && new_in != new_err)
posix_spawn_file_actions_addclose(&actions, new_in);
}
if (pipe_out != JANET_HANDLE_NONE) {
posix_spawn_file_actions_adddup2(&actions, pipe_out, 1);
posix_spawn_file_actions_addclose(&actions, pipe_out);
} else if (new_out != JANET_HANDLE_NONE) {
} else if (new_out != JANET_HANDLE_NONE && new_out != 1) {
posix_spawn_file_actions_adddup2(&actions, new_out, 1);
posix_spawn_file_actions_addclose(&actions, new_out);
if (new_out != new_err)
posix_spawn_file_actions_addclose(&actions, new_out);
}
if (pipe_err != JANET_HANDLE_NONE) {
posix_spawn_file_actions_adddup2(&actions, pipe_err, 2);
posix_spawn_file_actions_addclose(&actions, pipe_err);
} else if (new_err != JANET_HANDLE_NONE) {
} else if (new_err != JANET_HANDLE_NONE && new_err != 2) {
posix_spawn_file_actions_adddup2(&actions, new_err, 2);
posix_spawn_file_actions_addclose(&actions, new_err);
}
@@ -1044,7 +1187,8 @@ static Janet os_execute_impl(int32_t argc, Janet *argv, int is_spawn) {
os_execute_cleanup(envp, child_argv);
if (status) {
janet_panicf("%p: %s", argv[0], strerror(errno));
/* correct for macos bug where errno is not set */
janet_panicf("%p: %s", argv[0], strerror(errno ? errno : ENOENT));
}
#endif
@@ -1135,6 +1279,7 @@ static JanetEVGenericMessage os_shell_subr(JanetEVGenericMessage args) {
JANET_CORE_FN(os_shell,
"(os/shell str)",
"Pass a command string str directly to the system shell.") {
janet_sandbox_assert(JANET_SANDBOX_SUBPROCESS);
janet_arity(argc, 0, 1);
const char *cmd = argc
? janet_getcstring(argv, 0)
@@ -1154,6 +1299,7 @@ JANET_CORE_FN(os_shell,
JANET_CORE_FN(os_environ,
"(os/environ)",
"Get a copy of the OS environment table.") {
janet_sandbox_assert(JANET_SANDBOX_ENV);
(void) argv;
janet_fixarity(argc, 0);
int32_t nenv = 0;
@@ -1185,6 +1331,7 @@ JANET_CORE_FN(os_environ,
JANET_CORE_FN(os_getenv,
"(os/getenv variable &opt dflt)",
"Get the string value of an environment variable.") {
janet_sandbox_assert(JANET_SANDBOX_ENV);
janet_arity(argc, 1, 2);
const char *cstr = janet_getcstring(argv, 0);
const char *res = getenv(cstr);
@@ -1208,6 +1355,7 @@ JANET_CORE_FN(os_setenv,
#define SETENV(K,V) setenv(K, V, 1)
#define UNSETENV(K) unsetenv(K)
#endif
janet_sandbox_assert(JANET_SANDBOX_ENV);
janet_arity(argc, 1, 2);
const char *ks = janet_getcstring(argv, 0);
const char *vs = janet_optcstring(argv, argc, 1, NULL);
@@ -1232,13 +1380,32 @@ JANET_CORE_FN(os_time,
}
JANET_CORE_FN(os_clock,
"(os/clock)",
"Return the number of whole + fractional seconds since some fixed point in time. The clock "
"is guaranteed to be non-decreasing in real time.") {
janet_fixarity(argc, 0);
(void) argv;
"(os/clock &opt source)",
"Return the number of whole + fractional seconds of the requested clock source.\n\n"
"The `source` argument selects the clock source to use, when not specified the default "
"is `:realtime`:\n"
"- :realtime: Return the real (i.e., wall-clock) time. This clock is affected by discontinuous "
" jumps in the system time\n"
"- :monotonic: Return the number of whole + fractional seconds since some fixed point in "
" time. The clock is guaranteed to be non-decreasing in real time.\n"
"- :cputime: Return the CPU time consumed by this process (i.e. all threads in the process)\n") {
janet_sandbox_assert(JANET_SANDBOX_HRTIME);
janet_arity(argc, 0, 1);
enum JanetTimeSource source = JANET_TIME_REALTIME;
if (argc == 1) {
JanetKeyword sourcestr = janet_getkeyword(argv, 0);
if (janet_cstrcmp(sourcestr, "realtime") == 0) {
source = JANET_TIME_REALTIME;
} else if (janet_cstrcmp(sourcestr, "monotonic") == 0) {
source = JANET_TIME_MONOTONIC;
} else if (janet_cstrcmp(sourcestr, "cputime") == 0) {
source = JANET_TIME_CPUTIME;
} else {
janet_panicf("expected :realtime, :monotonic, or :cputime, got %v", argv[0]);
}
}
struct timespec tv;
if (janet_gettime(&tv)) janet_panic("could not get time");
if (janet_gettime(&tv, source)) janet_panic("could not get time");
double dtime = tv.tv_sec + (tv.tv_nsec / 1E9);
return janet_wrap_number(dtime);
}
@@ -1264,6 +1431,23 @@ JANET_CORE_FN(os_sleep,
return janet_wrap_nil();
}
JANET_CORE_FN(os_isatty,
"(os/isatty &opt file)",
"Returns true if `file` is a terminal. If `file` is not specified, "
"it will default to standard output.") {
janet_arity(argc, 0, 1);
FILE *f = (argc == 1) ? janet_getfile(argv, 0, NULL) : stdout;
#ifdef JANET_WINDOWS
int fd = _fileno(f);
if (fd == -1) janet_panic("not a valid stream");
return janet_wrap_boolean(_isatty(fd));
#else
int fd = fileno(f);
if (fd == -1) janet_panic(strerror(errno));
return janet_wrap_boolean(isatty(fd));
#endif
}
JANET_CORE_FN(os_cwd,
"(os/cwd)",
"Returns the current working directory.") {
@@ -1304,6 +1488,40 @@ JANET_CORE_FN(os_cryptorand,
return janet_wrap_buffer(buffer);
}
/* Helper function to get given or current time as local or UTC struct tm.
* - arg n+0: optional time_t to be converted, uses current time if not given
* - arg n+1: optional truthy to indicate the convnersion uses local time */
static struct tm *time_to_tm(const Janet *argv, int32_t argc, int32_t n, struct tm *t_infos) {
time_t t;
if (argc > n && !janet_checktype(argv[n], JANET_NIL)) {
int64_t integer = janet_getinteger64(argv, n);
t = (time_t) integer;
} else {
time(&t);
}
struct tm *t_info = NULL;
if (argc > n + 1 && janet_truthy(argv[n + 1])) {
/* local time */
#ifdef JANET_WINDOWS
_tzset();
localtime_s(t_infos, &t);
t_info = t_infos;
#else
tzset();
t_info = localtime_r(&t, t_infos);
#endif
} else {
/* utc time */
#ifdef JANET_WINDOWS
gmtime_s(t_infos, &t);
t_info = t_infos;
#else
t_info = gmtime_r(&t, t_infos);
#endif
}
return t_info;
}
JANET_CORE_FN(os_date,
"(os/date &opt time local)",
"Returns the given time as a date struct, or the current time if `time` is not given. "
@@ -1321,34 +1539,8 @@ JANET_CORE_FN(os_date,
"* :dst - if Day Light Savings is in effect") {
janet_arity(argc, 0, 2);
(void) argv;
time_t t;
struct tm t_infos;
struct tm *t_info = NULL;
if (argc && !janet_checktype(argv[0], JANET_NIL)) {
int64_t integer = janet_getinteger64(argv, 0);
t = (time_t) integer;
} else {
time(&t);
}
if (argc >= 2 && janet_truthy(argv[1])) {
/* local time */
#ifdef JANET_WINDOWS
_tzset();
localtime_s(&t_infos, &t);
t_info = &t_infos;
#else
tzset();
t_info = localtime_r(&t, &t_infos);
#endif
} else {
/* utc time */
#ifdef JANET_WINDOWS
gmtime_s(&t_infos, &t);
t_info = &t_infos;
#else
t_info = gmtime_r(&t, &t_infos);
#endif
}
struct tm *t_info = time_to_tm(argv, argc, 0, &t_infos);
JanetKV *st = janet_struct_begin(9);
janet_struct_put(st, janet_ckeywordv("seconds"), janet_wrap_number(t_info->tm_sec));
janet_struct_put(st, janet_ckeywordv("minutes"), janet_wrap_number(t_info->tm_min));
@@ -1362,6 +1554,34 @@ JANET_CORE_FN(os_date,
return janet_wrap_struct(janet_struct_end(st));
}
#define SIZETIMEFMT 250
JANET_CORE_FN(os_strftime,
"(os/strftime fmt &opt time local)",
"Format the given time as a string, or the current time if `time` is not given. "
"The time is formatted according to the same rules as the ISO C89 function strftime(). "
"The time is formatted in UTC unless `local` is truthy, in which case the date is formatted for "
"the local timezone.") {
janet_arity(argc, 1, 3);
const char *fmt = janet_getcstring(argv, 0);
/* ANSI X3.159-1989, section 4.12.3.5 "The strftime function" */
static const char *valid = "aAbBcdHIjmMpSUwWxXyYZ%";
const char *p = fmt;
while (*p) {
if (*p++ == '%') {
if (!strchr(valid, *p)) {
janet_panicf("invalid conversion specifier '%%%c'", *p);
}
p++;
}
}
struct tm t_infos;
struct tm *t_info = time_to_tm(argv, argc, 1, &t_infos);
char buf[SIZETIMEFMT];
(void)strftime(buf, SIZETIMEFMT, fmt, t_info);
return janet_cstringv(buf);
}
static int entry_getdst(Janet env_entry) {
Janet v;
if (janet_checktype(env_entry, JANET_TABLE)) {
@@ -1476,6 +1696,7 @@ JANET_CORE_FN(os_link,
"Iff symlink is truthy, creates a symlink. "
"Iff symlink is falsey or not provided, "
"creates a hard link. Does not work on Windows.") {
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
janet_arity(argc, 2, 3);
#ifdef JANET_WINDOWS
(void) argc;
@@ -1494,6 +1715,7 @@ JANET_CORE_FN(os_link,
JANET_CORE_FN(os_symlink,
"(os/symlink oldpath newpath)",
"Create a symlink from oldpath to newpath, returning nil. Same as `(os/link oldpath newpath true)`.") {
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
janet_fixarity(argc, 2);
#ifdef JANET_WINDOWS
(void) argc;
@@ -1516,6 +1738,7 @@ JANET_CORE_FN(os_mkdir,
"Create a new directory. The path will be relative to the current directory if relative, otherwise "
"it will be an absolute path. Returns true if the directory was created, false if the directory already exists, and "
"errors otherwise.") {
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
janet_fixarity(argc, 1);
const char *path = janet_getcstring(argv, 0);
#ifdef JANET_WINDOWS
@@ -1531,6 +1754,7 @@ JANET_CORE_FN(os_mkdir,
JANET_CORE_FN(os_rmdir,
"(os/rmdir path)",
"Delete a directory. The directory must be empty to succeed.") {
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
janet_fixarity(argc, 1);
const char *path = janet_getcstring(argv, 0);
#ifdef JANET_WINDOWS
@@ -1545,6 +1769,7 @@ JANET_CORE_FN(os_rmdir,
JANET_CORE_FN(os_cd,
"(os/cd path)",
"Change current directory to path. Returns nil on success, errors on failure.") {
janet_sandbox_assert(JANET_SANDBOX_FS_READ);
janet_fixarity(argc, 1);
const char *path = janet_getcstring(argv, 0);
#ifdef JANET_WINDOWS
@@ -1560,6 +1785,7 @@ JANET_CORE_FN(os_touch,
"(os/touch path &opt actime modtime)",
"Update the access time and modification times for a file. By default, sets "
"times to the current time.") {
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
janet_arity(argc, 1, 3);
const char *path = janet_getcstring(argv, 0);
struct utimbuf timebuf, *bufp;
@@ -1768,9 +1994,11 @@ static Janet os_stat_changed(jstat_t *st) {
}
#ifdef JANET_WINDOWS
static Janet os_stat_blocks(jstat_t *st) {
(void) st;
return janet_wrap_number(0);
}
static Janet os_stat_blocksize(jstat_t *st) {
(void) st;
return janet_wrap_number(0);
}
#else
@@ -1807,14 +2035,13 @@ static const struct OsStatGetter os_stat_getters[] = {
};
static Janet os_stat_or_lstat(int do_lstat, int32_t argc, Janet *argv) {
janet_sandbox_assert(JANET_SANDBOX_FS_READ);
janet_arity(argc, 1, 2);
const char *path = janet_getcstring(argv, 0);
JanetTable *tab = NULL;
int getall = 1;
const uint8_t *key;
const uint8_t *key = NULL;
if (argc == 2) {
if (janet_checktype(argv[1], JANET_KEYWORD)) {
getall = 0;
key = janet_getkeyword(argv, 1);
} else {
tab = janet_gettable(argv, 1);
@@ -1840,7 +2067,7 @@ static Janet os_stat_or_lstat(int do_lstat, int32_t argc, Janet *argv) {
return janet_wrap_nil();
}
if (getall) {
if (NULL == key) {
/* Put results in table */
for (const struct OsStatGetter *sg = os_stat_getters; sg->name != NULL; sg++) {
janet_table_put(tab, janet_ckeywordv(sg->name), sg->fn(&st));
@@ -1860,7 +2087,7 @@ 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"
"only that information from stat. If the file or directory does not exist, returns nil. The keys are:\n\n"
"* :dev - the device that the file is on\n\n"
"* :mode - the type of file, one of :file, :directory, :block, :character, :fifo, :socket, :link, or :other\n\n"
"* :int-permissions - A Unix permission integer like 8r744\n\n"
@@ -1890,6 +2117,7 @@ JANET_CORE_FN(os_chmod,
"`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.") {
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
janet_fixarity(argc, 2);
const char *path = janet_getcstring(argv, 0);
#ifdef JANET_WINDOWS
@@ -1905,6 +2133,7 @@ JANET_CORE_FN(os_chmod,
JANET_CORE_FN(os_umask,
"(os/umask mask)",
"Set a new umask, returns the old umask.") {
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
janet_fixarity(argc, 1);
int mask = (int) os_getmode(argv, 0);
#ifdef JANET_WINDOWS
@@ -1920,6 +2149,7 @@ JANET_CORE_FN(os_dir,
"(os/dir dir &opt array)",
"Iterate over files and subdirectories in a directory. Returns an array of paths parts, "
"with only the file name or directory name and no prefix.") {
janet_sandbox_assert(JANET_SANDBOX_FS_READ);
janet_arity(argc, 1, 2);
const char *dir = janet_getcstring(argv, 0);
JanetArray *paths = (argc == 2) ? janet_getarray(argv, 1) : janet_array(0);
@@ -1957,6 +2187,7 @@ JANET_CORE_FN(os_dir,
JANET_CORE_FN(os_rename,
"(os/rename oldname newname)",
"Rename a file on disk to a new path. Returns nil.") {
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
janet_fixarity(argc, 2);
const char *src = janet_getcstring(argv, 0);
const char *dest = janet_getcstring(argv, 1);
@@ -1970,7 +2201,8 @@ JANET_CORE_FN(os_rename,
JANET_CORE_FN(os_realpath,
"(os/realpath path)",
"Get the absolute path for a given path, following ../, ./, and symlinks. "
"Returns an absolute path as a string. Will raise an error on Windows.") {
"Returns an absolute path as a string.") {
janet_sandbox_assert(JANET_SANDBOX_FS_READ);
janet_fixarity(argc, 1);
const char *src = janet_getcstring(argv, 0);
#ifdef JANET_NO_REALPATH
@@ -2048,6 +2280,7 @@ JANET_CORE_FN(os_open,
uint32_t stream_flags = 0;
JanetHandle fd;
#ifdef JANET_WINDOWS
(void) mode;
DWORD desiredAccess = 0;
DWORD shareMode = 0;
DWORD creationDisp = 0;
@@ -2064,19 +2297,23 @@ JANET_CORE_FN(os_open,
case 'r':
desiredAccess |= GENERIC_READ;
stream_flags |= JANET_STREAM_READABLE;
janet_sandbox_assert(JANET_SANDBOX_FS_READ);
break;
case 'w':
desiredAccess |= GENERIC_WRITE;
stream_flags |= JANET_STREAM_WRITABLE;
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
break;
case 'c':
creatUnix |= OCREAT;
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
break;
case 'e':
creatUnix |= OEXCL;
break;
case 't':
creatUnix |= OTRUNC;
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
break;
/* Windows only flags */
case 'D':
@@ -2137,30 +2374,32 @@ JANET_CORE_FN(os_open,
#ifdef JANET_LINUX
open_flags |= O_CLOEXEC;
#endif
int read_flag = 0;
int write_flag = 0;
for (const uint8_t *c = opt_flags; *c; c++) {
switch (*c) {
default:
break;
case 'r':
open_flags = (open_flags & O_WRONLY)
? ((open_flags & ~O_WRONLY) | O_RDWR)
: (open_flags | O_RDONLY);
read_flag = 1;
stream_flags |= JANET_STREAM_READABLE;
janet_sandbox_assert(JANET_SANDBOX_FS_READ);
break;
case 'w':
open_flags = (open_flags & O_RDONLY)
? ((open_flags & ~O_RDONLY) | O_RDWR)
: (open_flags | O_WRONLY);
write_flag = 1;
stream_flags |= JANET_STREAM_WRITABLE;
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
break;
case 'c':
open_flags |= O_CREAT;
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
break;
case 'e':
open_flags |= O_EXCL;
break;
case 't':
open_flags |= O_TRUNC;
janet_sandbox_assert(JANET_SANDBOX_FS_WRITE);
break;
/* posix only */
case 'x':
@@ -2174,6 +2413,15 @@ JANET_CORE_FN(os_open,
break;
}
}
/* If both read and write, fix up to O_RDWR */
if (read_flag && !write_flag) {
open_flags |= O_RDONLY;
} else if (write_flag && !read_flag) {
open_flags |= O_WRONLY;
} else {
open_flags = O_RDWR;
}
do {
fd = open(path, open_flags, mode);
} while (fd == -1 && errno == EINTR);
@@ -2224,49 +2472,69 @@ void janet_lib_os(JanetTable *env) {
JANET_CORE_REG("os/exit", os_exit),
JANET_CORE_REG("os/which", os_which),
JANET_CORE_REG("os/arch", os_arch),
JANET_CORE_REG("os/compiler", os_compiler),
#ifndef JANET_REDUCED_OS
/* misc (un-sandboxed) */
JANET_CORE_REG("os/cpu-count", os_cpu_count),
JANET_CORE_REG("os/cwd", os_cwd),
JANET_CORE_REG("os/cryptorand", os_cryptorand),
JANET_CORE_REG("os/perm-string", os_permission_string),
JANET_CORE_REG("os/perm-int", os_permission_int),
JANET_CORE_REG("os/mktime", os_mktime),
JANET_CORE_REG("os/time", os_time), /* not high resolution */
JANET_CORE_REG("os/date", os_date), /* not high resolution */
JANET_CORE_REG("os/strftime", os_strftime),
JANET_CORE_REG("os/sleep", os_sleep),
JANET_CORE_REG("os/isatty", os_isatty),
/* env functions */
JANET_CORE_REG("os/environ", os_environ),
JANET_CORE_REG("os/getenv", os_getenv),
JANET_CORE_REG("os/setenv", os_setenv),
/* fs read */
JANET_CORE_REG("os/dir", os_dir),
JANET_CORE_REG("os/stat", os_stat),
JANET_CORE_REG("os/lstat", os_lstat),
JANET_CORE_REG("os/chmod", os_chmod),
JANET_CORE_REG("os/touch", os_touch),
JANET_CORE_REG("os/realpath", os_realpath),
JANET_CORE_REG("os/cd", os_cd),
JANET_CORE_REG("os/cpu-count", os_cpu_count),
#ifndef JANET_NO_UMASK
JANET_CORE_REG("os/umask", os_umask),
#endif
#ifndef JANET_NO_SYMLINKS
JANET_CORE_REG("os/readlink", os_readlink),
#endif
/* fs write */
JANET_CORE_REG("os/mkdir", os_mkdir),
JANET_CORE_REG("os/rmdir", os_rmdir),
JANET_CORE_REG("os/rm", os_remove),
JANET_CORE_REG("os/link", os_link),
JANET_CORE_REG("os/rename", os_rename),
#ifndef JANET_NO_SYMLINKS
JANET_CORE_REG("os/symlink", os_symlink),
JANET_CORE_REG("os/readlink", os_readlink),
#endif
/* processes */
#ifndef JANET_NO_PROCESSES
JANET_CORE_REG("os/execute", os_execute),
JANET_CORE_REG("os/spawn", os_spawn),
JANET_CORE_REG("os/shell", os_shell),
/* no need to sandbox process management if you can't create processes
* (allows for limited functionality if use exposes C-functions to create specific processes) */
JANET_CORE_REG("os/proc-wait", os_proc_wait),
JANET_CORE_REG("os/proc-kill", os_proc_kill),
JANET_CORE_REG("os/proc-close", os_proc_close),
#endif
JANET_CORE_REG("os/setenv", os_setenv),
JANET_CORE_REG("os/time", os_time),
JANET_CORE_REG("os/mktime", os_mktime),
/* high resolution timers */
JANET_CORE_REG("os/clock", os_clock),
JANET_CORE_REG("os/sleep", os_sleep),
JANET_CORE_REG("os/cwd", os_cwd),
JANET_CORE_REG("os/cryptorand", os_cryptorand),
JANET_CORE_REG("os/date", os_date),
JANET_CORE_REG("os/rename", os_rename),
JANET_CORE_REG("os/realpath", os_realpath),
JANET_CORE_REG("os/perm-string", os_permission_string),
JANET_CORE_REG("os/perm-int", os_permission_int),
#ifdef JANET_EV
JANET_CORE_REG("os/open", os_open),
JANET_CORE_REG("os/open", os_open), /* fs read and write */
JANET_CORE_REG("os/pipe", os_pipe),
#endif
#endif

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -1194,7 +1194,8 @@ static Janet parser_state_delimiters(const JanetParser *_p) {
}
}
}
str = janet_string(p->buf + oldcount, (int32_t)(p->bufcount - oldcount));
/* avoid ptr arithmetic on NULL */
str = janet_string(oldcount ? p->buf + oldcount : p->buf, (int32_t)(p->bufcount - oldcount));
p->bufcount = oldcount;
return janet_wrap_string(str);
}
@@ -1205,10 +1206,11 @@ static Janet parser_state_frames(const JanetParser *p) {
states->count = count;
uint8_t *buf = p->buf;
/* Iterate arg stack backwards */
Janet *args = p->args + p->argcount;
Janet *args = p->argcount ? p->args + p->argcount : p->args; /* avoid ptr arithmetic on NULL */
for (int32_t i = count - 1; i >= 0; --i) {
JanetParseState *s = p->states + i;
if (s->flags & PFLAG_CONTAINER) {
/* avoid ptr arithmetic on args if NULL */
if ((s->flags & PFLAG_CONTAINER) && s->argn) {
args -= s->argn;
}
states->data[i] = janet_wrap_parse_state(s, args, buf, (uint32_t) p->bufcount);

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -306,7 +306,7 @@ tail:
case RULE_THRU:
case RULE_TO: {
const uint32_t *rule_a = s->bytecode + rule[1];
const uint8_t *next_text;
const uint8_t *next_text = NULL;
CapState cs = cap_save(s);
down1(s);
while (text <= s->text_end) {
@@ -1034,7 +1034,7 @@ static void spec_capture_number(Builder *b, int32_t argc, const Janet *argv) {
emit_3(r, RULE_CAPTURE_NUM, rule, base, tag);
return;
error:
peg_panicf(b, "expected integer between 2 and 36, got %v", argv[2]);
peg_panicf(b, "expected integer between 2 and 36, got %v", argv[1]);
}
static void spec_reference(Builder *b, int32_t argc, const Janet *argv) {
@@ -1100,7 +1100,7 @@ static void spec_matchtime(Builder *b, int32_t argc, const Janet *argv) {
Janet fun = argv[1];
if (!janet_checktype(fun, JANET_FUNCTION) &&
!janet_checktype(fun, JANET_CFUNCTION)) {
peg_panicf(b, "expected function|cfunction, got %v", fun);
peg_panicf(b, "expected function or cfunction, got %v", fun);
}
uint32_t tag = (argc == 3) ? emit_tag(b, argv[2]) : 0;
uint32_t cindex = emit_constant(b, fun);
@@ -1261,6 +1261,13 @@ static uint32_t peg_compile1(Builder *b, Janet peg) {
default:
peg_panic(b, "unexpected peg source");
return 0;
case JANET_BOOLEAN: {
int n = janet_unwrap_boolean(peg);
Reserve r = reserve(b, 2);
emit_1(r, n ? RULE_NCHAR : RULE_NOTNCHAR, 0);
break;
}
case JANET_NUMBER: {
int32_t n = peg_getinteger(b, peg);
Reserve r = reserve(b, 2);
@@ -1637,7 +1644,7 @@ typedef struct {
JanetPeg *peg;
PegState s;
JanetByteView bytes;
JanetByteView repl;
Janet subst;
int32_t start;
} PegCall;
@@ -1653,7 +1660,7 @@ static PegCall peg_cfun_init(int32_t argc, Janet *argv, int get_replace) {
ret.peg = compile_peg(argv[0]);
}
if (get_replace) {
ret.repl = janet_getbytes(argv, 1);
ret.subst = argv[1];
ret.bytes = janet_getbytes(argv, 2);
} else {
ret.bytes = janet_getbytes(argv, 1);
@@ -1738,7 +1745,8 @@ static Janet cfun_peg_replace_generic(int32_t argc, Janet *argv, int only_one) {
trail = i;
}
int32_t nexti = (int32_t)(result - c.bytes.bytes);
janet_buffer_push_bytes(ret, c.repl.bytes, c.repl.len);
JanetByteView subst = janet_text_substitution(&c.subst, c.bytes.bytes + i, nexti - i, c.s.captures);
janet_buffer_push_bytes(ret, subst.bytes, subst.len);
trail = nexti;
if (nexti == i) nexti++;
i = nexti;
@@ -1754,14 +1762,20 @@ static Janet cfun_peg_replace_generic(int32_t argc, Janet *argv, int only_one) {
}
JANET_CORE_FN(cfun_peg_replace_all,
"(peg/replace-all peg repl text &opt start & args)",
"Replace all matches of peg in text with repl, returning a new buffer. The peg does not need to make captures to do replacement.") {
"(peg/replace-all peg subst text &opt start & args)",
"Replace all matches of `peg` in `text` with `subst`, returning a new buffer. "
"The peg does not need to make captures to do replacement. "
"If `subst` is a function, it will be called with the "
"matching text followed by any captures.") {
return cfun_peg_replace_generic(argc, argv, 0);
}
JANET_CORE_FN(cfun_peg_replace,
"(peg/replace peg repl text &opt start & args)",
"Replace first match of peg in text with repl, returning a new buffer. The peg does not need to make captures to do replacement. "
"Replace first match of `peg` in `text` with `subst`, returning a new buffer. "
"The peg does not need to make captures to do replacement. "
"If `subst` is a function, it will be called with the "
"matching text followed by any captures. "
"If no matches are found, returns the input string in a new buffer.") {
return cfun_peg_replace_generic(argc, argv, 1);
}

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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 <string.h>
#include <ctype.h>
#include <inttypes.h>
/* Implements a pretty printer for Janet. The pretty printer
* is simple and not that flexible, but fast. */
@@ -108,7 +109,7 @@ static void string_description_b(JanetBuffer *buffer, const char *title, void *p
pbuf.p = pointer;
*c++ = '<';
/* Maximum of 32 bytes for abstract type name */
for (i = 0; title[i] && i < 32; ++i)
for (i = 0; i < 32 && title[i]; ++i)
*c++ = ((uint8_t *)title) [i];
*c++ = ' ';
*c++ = '0';
@@ -636,7 +637,7 @@ static void janet_pretty_one(struct pretty *S, Janet x, int is_dict_value) {
}
}
janet_sorted_keys(kvs, cap, S->keysort_buffer + ks_start);
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;
@@ -735,7 +736,7 @@ static void pushtypes(JanetBuffer *buffer, int types) {
if (first) {
first = 0;
} else {
janet_buffer_push_u8(buffer, '|');
janet_buffer_push_cstring(buffer, (types == 1) ? " or " : ", ");
}
janet_buffer_push_cstring(buffer, janet_type_names[i]);
}
@@ -750,14 +751,41 @@ static void pushtypes(JanetBuffer *buffer, int types) {
#define MAX_ITEM 256
#define FMT_FLAGS "-+ #0"
#define FMT_REPLACE_INTTYPES "diouxX"
#define MAX_FORMAT 32
struct FmtMapping {
char c;
const char *mapping;
};
/* Janet uses fixed width integer types for most things, so map
* format specifiers to these fixed sizes */
static const struct FmtMapping format_mappings[] = {
{'d', PRId64},
{'i', PRIi64},
{'o', PRIo64},
{'u', PRIu64},
{'x', PRIx64},
{'X', PRIX64},
};
static const char *get_fmt_mapping(char c) {
for (size_t i = 0; i < (sizeof(format_mappings) / sizeof(struct FmtMapping)); i++) {
if (format_mappings[i].c == c)
return format_mappings[i].mapping;
}
janet_assert(0, "bad format mapping");
}
static const char *scanformat(
const char *strfrmt,
char *form,
char width[3],
char precision[3]) {
const char *p = strfrmt;
/* Parse strfrmt */
memset(width, '\0', 3);
memset(precision, '\0', 3);
while (*p != '\0' && strchr(FMT_FLAGS, *p) != NULL)
@@ -776,10 +804,23 @@ static const char *scanformat(
}
if (isdigit((int)(*p)))
janet_panic("invalid format (width or precision too long)");
/* Write to form - replace characters with fixed size stuff */
*(form++) = '%';
memcpy(form, strfrmt, ((p - strfrmt) + 1) * sizeof(char));
form += (p - strfrmt) + 1;
const char *p2 = strfrmt;
while (p2 <= p) {
char *loc = strchr(FMT_REPLACE_INTTYPES, *p2);
if (loc != NULL && *loc != '\0') {
const char *mapping = get_fmt_mapping(*p2++);
size_t len = strlen(mapping);
strcpy(form, mapping);
form += len;
} else {
*(form++) = *(p2++);
}
}
*form = '\0';
return p;
}
@@ -804,11 +845,16 @@ void janet_formatbv(JanetBuffer *b, const char *format, va_list args) {
break;
}
case 'd':
case 'i':
case 'o':
case 'i': {
int64_t n = va_arg(args, int);
nb = snprintf(item, MAX_ITEM, form, n);
break;
}
case 'x':
case 'X': {
int32_t n = va_arg(args, long);
case 'X':
case 'o':
case 'u': {
uint64_t n = va_arg(args, unsigned int);
nb = snprintf(item, MAX_ITEM, form, n);
break;
}
@@ -962,11 +1008,16 @@ void janet_buffer_format(
break;
}
case 'd':
case 'i':
case 'o':
case 'i': {
int64_t n = janet_getinteger64(argv, arg);
nb = snprintf(item, MAX_ITEM, form, n);
break;
}
case 'x':
case 'X': {
int32_t n = janet_getinteger(argv, arg);
case 'X':
case 'o':
case 'u': {
uint64_t n = janet_getuinteger64(argv, arg);
nb = snprintf(item, MAX_ITEM, form, n);
break;
}

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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,8 @@
#include "util.h"
#endif
/* The JanetRegisterAllocator is really just a bitset. */
void janetc_regalloc_init(JanetcRegisterAllocator *ra) {
ra->chunks = NULL;
ra->count = 0;
@@ -139,6 +141,14 @@ void janetc_regalloc_free(JanetcRegisterAllocator *ra, int32_t reg) {
ra->chunks[chunk] &= ~ithbit(bit);
}
/* Check if a register is set. */
int janetc_regalloc_check(JanetcRegisterAllocator *ra, int32_t reg) {
int32_t chunk = reg >> 5;
int32_t bit = reg & 0x1F;
while (chunk >= ra->count) pushchunk(ra);
return !!(ra->chunks[chunk] & ithbit(bit));
}
/* Get a register that will fit in 8 bits (< 256). Do not call this
* twice with the same value of nth without calling janetc_regalloc_free
* on the returned register before. */

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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,5 +56,6 @@ int32_t janetc_regalloc_temp(JanetcRegisterAllocator *ra, JanetcRegisterTemp nth
void janetc_regalloc_freetemp(JanetcRegisterAllocator *ra, int32_t reg, JanetcRegisterTemp nth);
void janetc_regalloc_clone(JanetcRegisterAllocator *dest, JanetcRegisterAllocator *src);
void janetc_regalloc_touch(JanetcRegisterAllocator *ra, int32_t reg);
int janetc_regalloc_check(JanetcRegisterAllocator *ra, int32_t reg);
#endif

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -39,6 +39,10 @@ static JanetSlot janetc_quote(JanetFopts opts, int32_t argn, const Janet *argv)
static JanetSlot janetc_splice(JanetFopts opts, int32_t argn, const Janet *argv) {
JanetSlot ret;
if (!(opts.flags & JANET_FOPTS_ACCEPT_SPLICE)) {
janetc_cerror(opts.compiler, "splice can only be used in function parameters and data constructors, it has no effect here");
return janetc_cslot(janet_wrap_nil());
}
if (argn != 1) {
janetc_cerror(opts.compiler, "expected 1 argument to splice");
return janetc_cslot(janet_wrap_nil());
@@ -75,7 +79,9 @@ static JanetSlot quasiquote(JanetFopts opts, Janet x, int depth, int level) {
const uint8_t *head = janet_unwrap_symbol(tup[0]);
if (!janet_cstrcmp(head, "unquote")) {
if (level == 0) {
return janetc_value(janetc_fopts_default(opts.compiler), tup[1]);
JanetFopts subopts = janetc_fopts_default(opts.compiler);
subopts.flags |= JANET_FOPTS_ACCEPT_SPLICE;
return janetc_value(subopts, tup[1]);
} else {
level--;
}
@@ -176,7 +182,6 @@ static int destructure(JanetCompiler *c,
return 1;
}
if (!janet_checktype(values[i + 1], JANET_SYMBOL)) {
janetc_error(c, janet_formatc("expected symbol following '& in destructuring pattern, found %q", values[i + 1]));
return 1;
@@ -203,8 +208,9 @@ static int destructure(JanetCompiler *c,
janetc_emit(c, JOP_JUMP);
int32_t label_loop_exit = janet_v_count(c->buffer);
c->buffer[label_loop_cond_jump] |= (label_loop_exit - label_loop_cond_jump) << 16;
c->buffer[label_loop_loop] |= (label_loop_start - label_loop_loop) << 8;
/* avoid shifting negative numbers */
c->buffer[label_loop_cond_jump] |= (uint32_t)(label_loop_exit - label_loop_cond_jump) << 16;
c->buffer[label_loop_loop] |= (uint32_t)(label_loop_start - label_loop_loop) << 8;
janetc_freeslot(c, argi);
janetc_freeslot(c, arg);
@@ -257,7 +263,7 @@ static const Janet *janetc_make_sourcemap(JanetCompiler *c) {
static JanetSlot janetc_varset(JanetFopts opts, int32_t argn, const Janet *argv) {
if (argn != 2) {
janetc_cerror(opts.compiler, "expected 2 arguments");
janetc_cerror(opts.compiler, "expected 2 arguments to set");
return janetc_cslot(janet_wrap_nil());
}
JanetFopts subopts = janetc_fopts_default(opts.compiler);
@@ -299,12 +305,16 @@ 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, int32_t argn, const Janet *argv) {
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]))
: "<multiple bindings>";
if (argn < 2) {
janetc_error(c, janet_formatc("expected at least 2 arguments to %s", kind));
return NULL;
}
for (i = 1; i < argn - 1; i++) {
Janet attr = argv[i];
switch (janet_type(attr)) {
@@ -328,18 +338,52 @@ static JanetTable *handleattr(JanetCompiler *c, int32_t argn, const Janet *argv)
return tab;
}
static JanetSlot dohead(JanetCompiler *c, JanetFopts opts, Janet *head, int32_t argn, const Janet *argv) {
typedef struct SlotHeadPair {
Janet lhs;
JanetSlot rhs;
} SlotHeadPair;
SlotHeadPair *dohead_destructure(JanetCompiler *c, SlotHeadPair *into, JanetFopts opts, Janet lhs, Janet rhs) {
/* Detect if we can do an optimization to avoid some allocations */
int can_destructure_lhs = janet_checktype(lhs, JANET_TUPLE)
|| janet_checktype(lhs, JANET_ARRAY);
int rhs_is_indexed = janet_checktype(rhs, JANET_ARRAY)
|| (janet_checktype(rhs, JANET_TUPLE) && (janet_tuple_flag(janet_unwrap_tuple(rhs)) & JANET_TUPLE_FLAG_BRACKETCTOR));
uint32_t has_drop = opts.flags & JANET_FOPTS_DROP;
JanetFopts subopts = janetc_fopts_default(c);
JanetSlot ret;
if (argn < 2) {
janetc_cerror(c, "expected at least 2 arguments");
return janetc_cslot(janet_wrap_nil());
}
*head = argv[0];
subopts.flags = opts.flags & ~(JANET_FOPTS_TAIL | JANET_FOPTS_DROP);
if (has_drop && can_destructure_lhs && rhs_is_indexed) {
/* Code is of the form (def [a b] [1 2]), avoid the allocation of two tuples */
JanetView view_lhs = {0};
JanetView view_rhs = {0};
janet_indexed_view(lhs, &view_lhs.items, &view_lhs.len);
janet_indexed_view(rhs, &view_rhs.items, &view_rhs.len);
int found_amp = 0;
for (int32_t i = 0; i < view_lhs.len; i++) {
if (janet_symeq(view_lhs.items[i], "&")) {
found_amp = 1;
/* Good error will be generated later. */
break;
}
}
if (!found_amp) {
for (int32_t i = 0; i < view_lhs.len; i++) {
Janet sub_rhs = view_rhs.len <= i ? janet_wrap_nil() : view_rhs.items[i];
into = dohead_destructure(c, into, subopts, view_lhs.items[i], sub_rhs);
}
return into;
}
}
/* No optimization, do the simple way */
subopts.hint = opts.hint;
ret = janetc_value(subopts, argv[argn - 1]);
return ret;
JanetSlot ret = janetc_value(subopts, rhs);
SlotHeadPair shp = {lhs, ret};
janet_v_push(into, shp);
return into;
}
/* Def or var a symbol in a local scope */
@@ -347,7 +391,17 @@ static int namelocal(JanetCompiler *c, const uint8_t *head, int32_t flags, Janet
int isUnnamedRegister = !(ret.flags & JANET_SLOT_NAMED) &&
ret.index > 0 &&
ret.envindex >= 0;
if (!isUnnamedRegister) {
/* optimization for `(def x my-def)` - don't emit a movn/movf instruction, we can just alias my-def */
/* TODO - implement optimization for `(def x my-var)` correctly as well w/ de-aliasing */
int canAlias = !(flags & JANET_SLOT_MUTABLE) &&
!(ret.flags & JANET_SLOT_MUTABLE) &&
(ret.flags & JANET_SLOT_NAMED) &&
(ret.index >= 0) &&
(ret.envindex == -1);
if (canAlias) {
ret.flags &= ~JANET_SLOT_MUTABLE;
isUnnamedRegister = 1; /* don't free slot after use - is an alias for another slot */
} else if (!isUnnamedRegister) {
/* Slot is not able to be named */
JanetSlot localslot = janetc_farslot(c);
janetc_copy(c, localslot, ret);
@@ -395,12 +449,23 @@ static int varleaf(
static JanetSlot janetc_var(JanetFopts opts, int32_t argn, const Janet *argv) {
JanetCompiler *c = opts.compiler;
Janet head;
JanetTable *attr_table = handleattr(c, argn, argv);
JanetSlot ret = dohead(c, opts, &head, argn, argv);
if (c->result.status == JANET_COMPILE_ERROR)
JanetTable *attr_table = handleattr(c, "var", argn, argv);
if (c->result.status == JANET_COMPILE_ERROR) {
return janetc_cslot(janet_wrap_nil());
destructure(c, argv[0], ret, varleaf, attr_table);
}
SlotHeadPair *into = NULL;
into = dohead_destructure(c, into, opts, argv[0], argv[argn - 1]);
if (c->result.status == JANET_COMPILE_ERROR) {
janet_v_free(into);
return janetc_cslot(janet_wrap_nil());
}
JanetSlot ret;
janet_assert(janet_v_count(into) > 0, "bad destructure");
for (int32_t i = 0; i < janet_v_count(into); i++) {
destructure(c, into[i].lhs, into[i].rhs, varleaf, attr_table);
ret = into[i].rhs;
}
janet_v_free(into);
return ret;
}
@@ -444,13 +509,24 @@ static int defleaf(
static JanetSlot janetc_def(JanetFopts opts, int32_t argn, const Janet *argv) {
JanetCompiler *c = opts.compiler;
Janet head;
opts.flags &= ~JANET_FOPTS_HINT;
JanetTable *attr_table = handleattr(c, argn, argv);
JanetSlot ret = dohead(c, opts, &head, argn, argv);
if (c->result.status == JANET_COMPILE_ERROR)
JanetTable *attr_table = handleattr(c, "def", argn, argv);
if (c->result.status == JANET_COMPILE_ERROR) {
return janetc_cslot(janet_wrap_nil());
destructure(c, argv[0], ret, defleaf, attr_table);
}
opts.flags &= ~JANET_FOPTS_HINT;
SlotHeadPair *into = NULL;
into = dohead_destructure(c, into, opts, argv[0], argv[argn - 1]);
if (c->result.status == JANET_COMPILE_ERROR) {
janet_v_free(into);
return janetc_cslot(janet_wrap_nil());
}
JanetSlot ret;
janet_assert(janet_v_count(into) > 0, "bad destructure");
for (int32_t i = 0; i < janet_v_count(into); i++) {
destructure(c, into[i].lhs, into[i].rhs, defleaf, attr_table);
ret = into[i].rhs;
}
janet_v_free(into);
return ret;
}
@@ -487,6 +563,7 @@ static JanetSlot janetc_if(JanetFopts opts, int32_t argn, const Janet *argv) {
/* Get options */
condopts = janetc_fopts_default(c);
bodyopts = opts;
bodyopts.flags &= ~JANET_FOPTS_ACCEPT_SPLICE;
/* Set target for compilation */
target = (drop || tail)
@@ -563,6 +640,7 @@ static JanetSlot janetc_do(JanetFopts opts, int32_t argn, const Janet *argv) {
subopts.flags = JANET_FOPTS_DROP;
} else {
subopts = opts;
subopts.flags &= ~JANET_FOPTS_ACCEPT_SPLICE;
}
ret = janetc_value(subopts, argv[i]);
if (i != argn - 1) {
@@ -573,7 +651,6 @@ static JanetSlot janetc_do(JanetFopts opts, int32_t argn, const Janet *argv) {
return ret;
}
/* Compile an upscope form. Upscope forms execute their body sequentially and
* evaluate to the last expression in the body, but without lexical scope. */
static JanetSlot janetc_upscope(JanetFopts opts, int32_t argn, const Janet *argv) {
@@ -586,6 +663,7 @@ static JanetSlot janetc_upscope(JanetFopts opts, int32_t argn, const Janet *argv
subopts.flags = JANET_FOPTS_DROP;
} else {
subopts = opts;
subopts.flags &= ~JANET_FOPTS_ACCEPT_SPLICE;
}
ret = janetc_value(subopts, argv[i]);
if (i != argn - 1) {
@@ -697,8 +775,8 @@ static JanetSlot janetc_while(JanetFopts opts, int32_t argn, const Janet *argv)
uint8_t ifjmp = JOP_JUMP_IF;
uint8_t ifnjmp = JOP_JUMP_IF_NOT;
if (argn < 2) {
janetc_cerror(c, "expected at least 2 arguments");
if (argn < 1) {
janetc_cerror(c, "expected at least 1 argument to while");
return janetc_cslot(janet_wrap_nil());
}
@@ -813,7 +891,7 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) {
JanetSlot ret;
Janet head;
JanetScope fnscope;
int32_t paramcount, argi, parami, arity, min_arity, max_arity, defindex, i;
int32_t paramcount, argi, parami, arity, min_arity = 0, max_arity, defindex, i;
JanetFopts subopts = janetc_fopts_default(c);
const Janet *params;
const char *errmsg = NULL;
@@ -940,6 +1018,7 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) {
for (i = 0; i < paramcount; i++) {
Janet param = params[i];
if (!janet_checktype(param, JANET_SYMBOL)) {
janet_assert(janet_v_count(destructed_params) > j, "out of bounds");
JanetSlot reg = destructed_params[j++];
destructure(c, param, reg, defleaf, NULL);
janetc_freeslot(c, reg);
@@ -958,12 +1037,26 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) {
max_arity = (vararg || allow_extra) ? INT32_MAX : arity;
if (!seenopt) min_arity = arity;
/* Check for self ref */
/* Check for self ref (also avoid if arguments shadow own name) */
if (selfref) {
JanetSlot slot = janetc_farslot(c);
slot.flags = JANET_SLOT_NAMED | JANET_FUNCTION;
janetc_emit_s(c, JOP_LOAD_SELF, slot, 1);
janetc_nameslot(c, janet_unwrap_symbol(head), slot);
/* Check if the parameters shadow the function name. If so, don't
* emit JOP_LOAD_SELF and add a binding since that most users
* seem to expect that function parameters take precedence over the
* function name */
const uint8_t *sym = janet_unwrap_symbol(head);
int32_t len = janet_v_count(c->scope->syms);
int found = 0;
for (int32_t i = 0; i < len; i++) {
if (c->scope->syms[i].sym == sym) {
found = 1;
}
}
if (!found) {
JanetSlot slot = janetc_farslot(c);
slot.flags = JANET_SLOT_NAMED | JANET_FUNCTION;
janetc_emit_s(c, JOP_LOAD_SELF, slot, 1);
janetc_nameslot(c, sym, slot);
}
}
/* Compile function body */
@@ -1030,4 +1123,3 @@ const JanetSpecial *janetc_special(const uint8_t *name) {
sizeof(JanetSpecial),
name);
}

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -23,8 +23,15 @@
#ifndef JANET_STATE_H_defined
#define JANET_STATE_H_defined
#include <janet.h>
#include <stdint.h>
#ifdef JANET_EV
#ifndef JANET_WINDOWS
#include <pthread.h>
#endif
#endif
typedef int64_t JanetTimestamp;
typedef struct JanetScratch {
@@ -54,7 +61,7 @@ typedef struct {
int is_error;
} JanetTimeout;
/* Registry table for C functions - containts metadata that can
/* Registry table for C functions - contains metadata that can
* be looked up by cfunction pointer. All strings here are pointing to
* static memory not managed by Janet. */
typedef struct {
@@ -85,7 +92,7 @@ struct JanetVM {
int auto_suspend;
/* The current running fiber on the current thread.
* Set and unset by janet_run. */
* Set and unset by functions in vm.c */
JanetFiber *fiber;
JanetFiber *root_fiber;
@@ -101,7 +108,7 @@ struct JanetVM {
size_t registry_count;
int registry_dirty;
/* Registry for abstract abstract types that can be marshalled.
/* Registry for abstract types that can be marshalled.
* We need this to look up the constructors when unmarshalling. */
JanetTable *abstract_registry;
@@ -129,6 +136,9 @@ struct JanetVM {
size_t scratch_cap;
size_t scratch_len;
/* Sandbox flags */
uint32_t sandbox_flags;
/* Random number generator */
JanetRNG rng;
@@ -149,19 +159,23 @@ struct JanetVM {
size_t listener_cap;
size_t extra_listeners;
JanetTable threaded_abstracts; /* All abstract types that can be shared between threads (used in this thread) */
JanetTable active_tasks; /* All possibly live task fibers - used just for tracking */
#ifdef JANET_WINDOWS
void **iocp;
#elif defined(JANET_EV_EPOLL)
pthread_attr_t new_thread_attr;
JanetHandle selfpipe[2];
int epoll;
int timerfd;
int timer_enabled;
#elif defined(JANET_EV_KQUEUE)
pthread_attr_t new_thread_attr;
JanetHandle selfpipe[2];
int kq;
int timer;
int timer_enabled;
#else
pthread_attr_t new_thread_attr;
JanetHandle selfpipe[2];
struct pollfd *fds;
#endif

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -364,14 +364,13 @@ JANET_CORE_FN(cfun_string_findall,
struct replace_state {
struct kmp_state kmp;
const uint8_t *subst;
int32_t substlen;
Janet subst;
};
static void replacesetup(int32_t argc, Janet *argv, struct replace_state *s) {
janet_arity(argc, 3, 4);
JanetByteView pat = janet_getbytes(argv, 0);
JanetByteView subst = janet_getbytes(argv, 1);
Janet subst = argv[1];
JanetByteView text = janet_getbytes(argv, 2);
int32_t start = 0;
if (argc == 4) {
@@ -380,13 +379,14 @@ static void replacesetup(int32_t argc, Janet *argv, struct replace_state *s) {
}
kmp_init(&s->kmp, text.bytes, text.len, pat.bytes, pat.len);
s->kmp.i = start;
s->subst = subst.bytes;
s->substlen = subst.len;
s->subst = subst;
}
JANET_CORE_FN(cfun_string_replace,
"(string/replace patt subst str)",
"Replace the first occurrence of `patt` with `subst` in the string `str`. "
"If `subst` is a function, it will be called with `patt` only if a match is found, "
"and should return the actual replacement text to use. "
"Will return the new string if `patt` is found, otherwise returns `str`.") {
int32_t result;
struct replace_state s;
@@ -397,10 +397,11 @@ JANET_CORE_FN(cfun_string_replace,
kmp_deinit(&s.kmp);
return janet_stringv(s.kmp.text, s.kmp.textlen);
}
buf = janet_string_begin(s.kmp.textlen - s.kmp.patlen + s.substlen);
JanetByteView subst = janet_text_substitution(&s.subst, s.kmp.text + result, s.kmp.patlen, NULL);
buf = janet_string_begin(s.kmp.textlen - s.kmp.patlen + subst.len);
safe_memcpy(buf, s.kmp.text, result);
safe_memcpy(buf + result, s.subst, s.substlen);
safe_memcpy(buf + result + s.substlen,
safe_memcpy(buf + result, subst.bytes, subst.len);
safe_memcpy(buf + result + subst.len,
s.kmp.text + result + s.kmp.patlen,
s.kmp.textlen - result - s.kmp.patlen);
kmp_deinit(&s.kmp);
@@ -411,6 +412,8 @@ JANET_CORE_FN(cfun_string_replaceall,
"(string/replace-all patt subst str)",
"Replace all instances of `patt` with `subst` in the string `str`. Overlapping "
"matches will not be counted, only the first match in such a span will be replaced. "
"If `subst` is a function, it will be called with `patt` once for each match, "
"and should return the actual replacement text to use. "
"Will return the new string if `patt` is found, otherwise returns `str`.") {
int32_t result;
struct replace_state s;
@@ -419,8 +422,9 @@ JANET_CORE_FN(cfun_string_replaceall,
replacesetup(argc, argv, &s);
janet_buffer_init(&b, s.kmp.textlen);
while ((result = kmp_next(&s.kmp)) >= 0) {
JanetByteView subst = janet_text_substitution(&s.subst, s.kmp.text + result, s.kmp.patlen, NULL);
janet_buffer_push_bytes(&b, s.kmp.text + lastindex, result - lastindex);
janet_buffer_push_bytes(&b, s.subst, s.substlen);
janet_buffer_push_bytes(&b, subst.bytes, subst.len);
lastindex = result + s.kmp.patlen;
kmp_seti(&s.kmp, lastindex);
}
@@ -531,7 +535,30 @@ JANET_CORE_FN(cfun_string_join,
JANET_CORE_FN(cfun_string_format,
"(string/format format & values)",
"Similar to C's `snprintf`, but specialized for operating with Janet values. Returns "
"a new string.") {
"a new string.\n\n"
"The following conversion specifiers are supported, where the upper case specifiers generate "
"upper case output:\n"
"- `c`: ASCII character.\n"
"- `d`, `i`: integer, formatted as a decimal number.\n"
"- `x`, `X`: integer, formatted as a hexadecimal number.\n"
"- `o`: integer, formatted as an octal number.\n"
"- `f`, `F`: floating point number, formatted as a decimal number.\n"
"- `e`, `E`: floating point number, formatted in scientific notation.\n"
"- `g`, `G`: floating point number, formatted in its shortest form.\n"
"- `a`, `A`: floating point number, formatted as a hexadecimal number.\n"
"- `s`: formatted as a string, precision indicates padding and maximum length.\n"
"- `t`: emit the type of the given value.\n"
"- `v`: format with (describe x)"
"- `V`: format with (string x)"
"- `j`: format to jdn (Janet data notation).\n"
"\n"
"The following conversion specifiers are used for \"pretty-printing\", where the upper-case "
"variants generate colored output. These speficiers can take a precision "
"argument to specify the maximum nesting depth to print.\n"
"- `p`, `P`: pretty format, truncating if necessary\n"
"- `m`, `M`: pretty format without truncating.\n"
"- `q`, `Q`: pretty format on one line, truncating if necessary.\n"
"- `n`, `N`: pretty format on one line without truncation.\n") {
janet_arity(argc, 1, -1);
JanetBuffer *buffer = janet_buffer(0);
const char *strfrmt = (const char *) janet_getstring(argv, 0);

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -108,6 +108,7 @@ static const uint8_t **janet_symcache_findmem(
}
notfound:
*success = 0;
janet_assert(firstEmpty != NULL, "symcache failed to get memory");
return firstEmpty;
}

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -39,9 +39,11 @@
#ifdef JANET_WINDOWS
#ifdef JANET_DYNAMIC_MODULES
#include <psapi.h>
#ifdef JANET_MSVC
#pragma comment (lib, "Psapi.lib")
#endif
#endif
#endif
#ifdef JANET_APPLE
#include <AvailabilityMacros.h>
@@ -90,8 +92,8 @@ const char *const janet_signal_names[14] = {
"user5",
"user6",
"user7",
"user8",
"user9"
"interrupt",
"await"
};
const char *const janet_status_names[16] = {
@@ -107,8 +109,8 @@ const char *const janet_status_names[16] = {
"user5",
"user6",
"user7",
"user8",
"user9",
"interrupted",
"suspended",
"new",
"alive"
};
@@ -116,6 +118,7 @@ const char *const janet_status_names[16] = {
#ifndef JANET_PRF
int32_t janet_string_calchash(const uint8_t *str, int32_t len) {
if (NULL == str) return 5381;
const uint8_t *end = str + len;
uint32_t hash = 5381;
while (str < end)
@@ -496,7 +499,7 @@ typedef struct {
static void namebuf_init(NameBuf *namebuf, const char *prefix) {
size_t plen = strlen(prefix);
namebuf->plen = plen;
namebuf->buf = janet_malloc(namebuf->plen + 256);
namebuf->buf = janet_smalloc(namebuf->plen + 256);
if (NULL == namebuf->buf) {
JANET_OUT_OF_MEMORY;
}
@@ -505,12 +508,12 @@ static void namebuf_init(NameBuf *namebuf, const char *prefix) {
}
static void namebuf_deinit(NameBuf *namebuf) {
janet_free(namebuf->buf);
janet_sfree(namebuf->buf);
}
static char *namebuf_name(NameBuf *namebuf, const char *suffix) {
size_t slen = strlen(suffix);
namebuf->buf = janet_realloc(namebuf->buf, namebuf->plen + 2 + slen);
namebuf->buf = janet_srealloc(namebuf->buf, namebuf->plen + 2 + slen);
if (NULL == namebuf->buf) {
JANET_OUT_OF_MEMORY;
}
@@ -660,6 +663,59 @@ JanetBinding janet_binding_from_entry(Janet entry) {
return binding;
}
/* If the value at the given address can be coerced to a byte view,
return that byte view. If it can't, replace the value at the address
with the result of janet_to_string, and return a byte view over that
string. */
static JanetByteView memoize_byte_view(Janet *value) {
JanetByteView result;
if (!janet_bytes_view(*value, &result.bytes, &result.len)) {
JanetString str = janet_to_string(*value);
*value = janet_wrap_string(str);
result.bytes = str;
result.len = janet_string_length(str);
}
return result;
}
static JanetByteView to_byte_view(Janet value) {
JanetByteView result;
if (!janet_bytes_view(value, &result.bytes, &result.len)) {
JanetString str = janet_to_string(value);
result.bytes = str;
result.len = janet_string_length(str);
}
return result;
}
JanetByteView janet_text_substitution(
Janet *subst,
const uint8_t *bytes,
uint32_t len,
JanetArray *extra_argv) {
int32_t extra_argc = extra_argv == NULL ? 0 : extra_argv->count;
JanetType type = janet_type(*subst);
switch (type) {
case JANET_FUNCTION:
case JANET_CFUNCTION: {
int32_t argc = 1 + extra_argc;
Janet *argv = janet_tuple_begin(argc);
argv[0] = janet_stringv(bytes, len);
for (int32_t i = 0; i < extra_argc; i++) {
argv[i + 1] = extra_argv->data[i];
}
janet_tuple_end(argv);
if (type == JANET_FUNCTION) {
return to_byte_view(janet_call(janet_unwrap_function(*subst), argc, argv));
} else {
return to_byte_view(janet_unwrap_cfunction(*subst)(argc, argv));
}
}
default:
return memoize_byte_view(subst);
}
}
JanetBinding janet_resolve_ext(JanetTable *env, const uint8_t *sym) {
Janet entry = janet_table_get(env, janet_wrap_symbol(sym));
return janet_binding_from_entry(entry);
@@ -701,15 +757,25 @@ int janet_indexed_view(Janet seq, const Janet **data, int32_t *len) {
/* Read both strings and buffer as unsigned character array + int32_t len.
* Returns 1 if the view can be constructed and 0 if the type is invalid. */
int janet_bytes_view(Janet str, const uint8_t **data, int32_t *len) {
if (janet_checktype(str, JANET_STRING) || janet_checktype(str, JANET_SYMBOL) ||
janet_checktype(str, JANET_KEYWORD)) {
JanetType t = janet_type(str);
if (t == JANET_STRING || t == JANET_SYMBOL || t == JANET_KEYWORD) {
*data = janet_unwrap_string(str);
*len = janet_string_length(janet_unwrap_string(str));
return 1;
} else if (janet_checktype(str, JANET_BUFFER)) {
} else if (t == JANET_BUFFER) {
*data = janet_unwrap_buffer(str)->data;
*len = janet_unwrap_buffer(str)->count;
return 1;
} else if (t == JANET_ABSTRACT) {
void *abst = janet_unwrap_abstract(str);
const JanetAbstractType *atype = janet_abstract_type(abst);
if (NULL == atype->bytes) {
return 0;
}
JanetByteView view = atype->bytes(abst, janet_abstract_size(abst));
*data = view.bytes;
*len = view.len;
return 1;
}
return 0;
}
@@ -739,6 +805,13 @@ int janet_checkint(Janet x) {
return janet_checkintrange(dval);
}
int janet_checkuint(Janet x) {
if (!janet_checktype(x, JANET_NUMBER))
return 0;
double dval = janet_unwrap_number(x);
return janet_checkuintrange(dval);
}
int janet_checkint64(Janet x) {
if (!janet_checktype(x, JANET_NUMBER))
return 0;
@@ -750,7 +823,7 @@ int janet_checkuint64(Janet x) {
if (!janet_checktype(x, JANET_NUMBER))
return 0;
double dval = janet_unwrap_number(x);
return dval >= 0 && dval <= JANET_INTMAX_DOUBLE && dval == (uint64_t) dval;
return janet_checkuint64range(dval);
}
int janet_checksize(Janet x) {
@@ -809,34 +882,73 @@ int32_t janet_sorted_keys(const JanetKV *dict, int32_t cap, int32_t *index_buffe
/* Clock shims for various platforms */
#ifdef JANET_GETTIME
#ifdef JANET_WINDOWS
int janet_gettime(struct timespec *spec) {
FILETIME ftime;
GetSystemTimeAsFileTime(&ftime);
int64_t wintime = (int64_t)(ftime.dwLowDateTime) | ((int64_t)(ftime.dwHighDateTime) << 32);
/* Windows epoch is January 1, 1601 apparently */
wintime -= 116444736000000000LL;
spec->tv_sec = wintime / 10000000LL;
/* Resolution is 100 nanoseconds. */
spec->tv_nsec = wintime % 10000000LL * 100;
#include <profileapi.h>
int janet_gettime(struct timespec *spec, enum JanetTimeSource source) {
if (source == JANET_TIME_REALTIME) {
FILETIME ftime;
GetSystemTimeAsFileTime(&ftime);
int64_t wintime = (int64_t)(ftime.dwLowDateTime) | ((int64_t)(ftime.dwHighDateTime) << 32);
/* Windows epoch is January 1, 1601 apparently */
wintime -= 116444736000000000LL;
spec->tv_sec = wintime / 10000000LL;
/* Resolution is 100 nanoseconds. */
spec->tv_nsec = wintime % 10000000LL * 100;
} else if (source == JANET_TIME_MONOTONIC) {
LARGE_INTEGER count;
LARGE_INTEGER perf_freq;
QueryPerformanceCounter(&count);
QueryPerformanceFrequency(&perf_freq);
spec->tv_sec = count.QuadPart / perf_freq.QuadPart;
spec->tv_nsec = (long)((count.QuadPart % perf_freq.QuadPart) * 1000000000 / perf_freq.QuadPart);
} else if (source == JANET_TIME_CPUTIME) {
FILETIME creationTime, exitTime, kernelTime, userTime;
GetProcessTimes(GetCurrentProcess(), &creationTime, &exitTime, &kernelTime, &userTime);
int64_t tmp = ((int64_t)userTime.dwHighDateTime << 32) + userTime.dwLowDateTime;
spec->tv_sec = tmp / 10000000LL;
spec->tv_nsec = tmp % 10000000LL * 100;
}
return 0;
}
/* clock_gettime() wasn't available on Mac until 10.12. */
#elif defined(JANET_APPLE) && !defined(MAC_OS_X_VERSION_10_12)
#include <mach/clock.h>
#include <mach/mach.h>
int janet_gettime(struct timespec *spec) {
clock_serv_t cclock;
mach_timespec_t mts;
host_get_clock_service(mach_host_self(), CALENDAR_CLOCK, &cclock);
clock_get_time(cclock, &mts);
mach_port_deallocate(mach_task_self(), cclock);
spec->tv_sec = mts.tv_sec;
spec->tv_nsec = mts.tv_nsec;
int janet_gettime(struct timespec *spec, enum JanetTimeSource source) {
if (source == JANET_TIME_REALTIME) {
clock_serv_t cclock;
mach_timespec_t mts;
host_get_clock_service(mach_host_self(), CALENDAR_CLOCK, &cclock);
clock_get_time(cclock, &mts);
mach_port_deallocate(mach_task_self(), cclock);
spec->tv_sec = mts.tv_sec;
spec->tv_nsec = mts.tv_nsec;
} else if (source == JANET_TIME_MONOTONIC) {
clock_serv_t cclock;
int nsecs;
mach_msg_type_number_t count;
host_get_clock_service(mach_host_self(), clock, &cclock);
clock_get_attributes(cclock, CLOCK_GET_TIME_RES, (clock_attr_t)&nsecs, &count);
mach_port_deallocate(mach_task_self(), cclock);
clock_getres(CLOCK_MONOTONIC, spec);
}
if (source == JANET_TIME_CPUTIME) {
clock_t tmp = clock();
spec->tv_sec = tmp;
spec->tv_nsec = (tmp - spec->tv_sec) * 1.0e9;
}
return 0;
}
#else
int janet_gettime(struct timespec *spec) {
return clock_gettime(CLOCK_REALTIME, spec);
int janet_gettime(struct timespec *spec, enum JanetTimeSource source) {
clockid_t cid = CLOCK_REALTIME;
if (source == JANET_TIME_REALTIME) {
cid = CLOCK_REALTIME;
} else if (source == JANET_TIME_MONOTONIC) {
cid = CLOCK_MONOTONIC;
} else if (source == JANET_TIME_CPUTIME) {
cid = CLOCK_PROCESS_CPUTIME_ID;
}
return clock_gettime(cid, spec);
}
#endif
#endif
@@ -853,13 +965,13 @@ int janet_cryptorand(uint8_t *out, size_t n) {
unsigned int v;
if (rand_s(&v))
return -1;
for (int32_t j = 0; (j < sizeof(unsigned int)) && (i + j < n); j++) {
for (int32_t j = 0; (j < (int32_t) sizeof(unsigned int)) && (i + j < n); j++) {
out[i + j] = v & 0xff;
v = v >> 8;
}
}
return 0;
#elif defined(JANET_LINUX) || ( defined(JANET_APPLE) && !defined(MAC_OS_X_VERSION_10_7) )
#elif defined(JANET_LINUX) || defined(JANET_CYGWIN) || ( defined(JANET_APPLE) && !defined(MAC_OS_X_VERSION_10_7) )
/* We should be able to call getrandom on linux, but it doesn't seem
to be uniformly supported on linux distros.
On Mac, arc4random_buf wasn't available on until 10.7.
@@ -910,6 +1022,13 @@ char *get_processed_name(const char *name) {
return ret;
}
#if defined(JANET_NO_DYNAMIC_MODULES)
const char *error_clib(void) {
return "dynamic modules not supported";
}
#else
#if defined(JANET_WINDOWS)
static char error_clib_buf[256];
@@ -957,6 +1076,7 @@ void *symbol_clib(HINSTANCE clib, const char *sym) {
}
}
#endif
#endif
/* Alloc function macro fills */

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -93,6 +93,11 @@ void janet_buffer_format(
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);
/* Registry functions */
void janet_registry_put(
@@ -121,7 +126,12 @@ void janet_core_cfuns_ext(JanetTable *env, const char *regprefix, const JanetReg
/* Clock gettime */
#ifdef JANET_GETTIME
int janet_gettime(struct timespec *spec);
enum JanetTimeSource {
JANET_TIME_REALTIME,
JANET_TIME_MONOTONIC,
JANET_TIME_CPUTIME
};
int janet_gettime(struct timespec *spec, enum JanetTimeSource source);
#endif
/* strdup */
@@ -135,7 +145,7 @@ int janet_gettime(struct timespec *spec);
typedef int Clib;
#define load_clib(name) ((void) name, 0)
#define symbol_clib(lib, sym) ((void) lib, (void) sym, NULL)
#define error_clib() "dynamic libraries not supported"
const char *error_clib(void);
#define free_clib(c) ((void) (c), 0)
#elif defined(JANET_WINDOWS)
#include <windows.h>
@@ -150,7 +160,7 @@ typedef void *Clib;
#define load_clib(name) dlopen((name), RTLD_NOW)
#define free_clib(lib) dlclose((lib))
#define symbol_clib(lib, sym) dlsym((lib), (sym))
#define error_clib() dlerror()
#define error_clib dlerror
#endif
char *get_processed_name(const char *name);

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -272,6 +272,7 @@ int janet_equals(Janet x, Janet y) {
const Janet *t1 = janet_unwrap_tuple(x);
const Janet *t2 = janet_unwrap_tuple(y);
if (t1 == t2) break;
if (JANET_TUPLE_FLAG_BRACKETCTOR & (janet_tuple_flag(t1) ^ janet_tuple_flag(t2))) return 0;
if (janet_tuple_hash(t1) != janet_tuple_hash(t2)) return 0;
if (janet_tuple_length(t1) != janet_tuple_length(t2)) return 0;
push_traversal_node(janet_tuple_head(t1), janet_tuple_head(t2), 0);
@@ -321,6 +322,7 @@ 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;
break;
case JANET_STRUCT:
hash = janet_struct_hash(janet_unwrap_struct(x));
@@ -412,6 +414,9 @@ int janet_compare(Janet x, Janet y) {
case JANET_TUPLE: {
const Janet *lhs = janet_unwrap_tuple(x);
const Janet *rhs = janet_unwrap_tuple(y);
if (JANET_TUPLE_FLAG_BRACKETCTOR & (janet_tuple_flag(lhs) ^ janet_tuple_flag(rhs))) {
return (janet_tuple_flag(lhs) & JANET_TUPLE_FLAG_BRACKETCTOR) ? 1 : -1;
}
push_traversal_node(janet_tuple_head(lhs), janet_tuple_head(rhs), 1);
break;
}
@@ -434,20 +439,21 @@ int janet_compare(Janet x, Janet y) {
return status - 2;
}
static int32_t getter_checkint(Janet key, int32_t max) {
static int32_t getter_checkint(JanetType type, Janet key, int32_t max) {
if (!janet_checkint(key)) goto bad;
int32_t ret = janet_unwrap_integer(key);
if (ret < 0) goto bad;
if (ret >= max) goto bad;
return ret;
bad:
janet_panicf("expected integer key in range [0, %d), got %v", max, key);
janet_panicf("expected integer key for %s in range [0, %d), got %v", janet_type_names[type], max, key);
}
/* Gets a value and returns. Can panic. */
Janet janet_in(Janet ds, Janet key) {
Janet value;
switch (janet_type(ds)) {
JanetType type = janet_type(ds);
switch (type) {
default:
janet_panicf("expected %T, got %v", JANET_TFLAG_LENGTHABLE, ds);
break;
@@ -459,19 +465,19 @@ Janet janet_in(Janet ds, Janet key) {
break;
case JANET_ARRAY: {
JanetArray *array = janet_unwrap_array(ds);
int32_t index = getter_checkint(key, array->count);
int32_t index = getter_checkint(type, key, array->count);
value = array->data[index];
break;
}
case JANET_TUPLE: {
const Janet *tuple = janet_unwrap_tuple(ds);
int32_t len = janet_tuple_length(tuple);
value = tuple[getter_checkint(key, len)];
value = tuple[getter_checkint(type, key, len)];
break;
}
case JANET_BUFFER: {
JanetBuffer *buffer = janet_unwrap_buffer(ds);
int32_t index = getter_checkint(key, buffer->count);
int32_t index = getter_checkint(type, key, buffer->count);
value = janet_wrap_integer(buffer->data[index]);
break;
}
@@ -479,7 +485,7 @@ Janet janet_in(Janet ds, Janet key) {
case JANET_SYMBOL:
case JANET_KEYWORD: {
const uint8_t *str = janet_unwrap_string(ds);
int32_t index = getter_checkint(key, janet_string_length(str));
int32_t index = getter_checkint(type, key, janet_string_length(str));
value = janet_wrap_integer(str[index]);
break;
}
@@ -651,6 +657,15 @@ int32_t janet_length(Janet x) {
case JANET_TABLE:
return janet_unwrap_table(x)->count;
case JANET_ABSTRACT: {
void *abst = janet_unwrap_abstract(x);
const JanetAbstractType *type = janet_abstract_type(abst);
if (type->length != NULL) {
size_t len = type->length(abst, janet_abstract_size(abst));
if (len > INT32_MAX) {
janet_panicf("invalid integer length %u", len);
}
return (int32_t)(len);
}
Janet argv[1] = { x };
Janet len = janet_mcall("length", 1, argv);
if (!janet_checkint(len))
@@ -679,6 +694,21 @@ Janet janet_lengthv(Janet x) {
case JANET_TABLE:
return janet_wrap_integer(janet_unwrap_table(x)->count);
case JANET_ABSTRACT: {
void *abst = janet_unwrap_abstract(x);
const JanetAbstractType *type = janet_abstract_type(abst);
if (type->length != NULL) {
size_t len = type->length(abst, janet_abstract_size(abst));
/* If len is always less then double, we can never overflow */
#ifdef JANET_32
return janet_wrap_number(len);
#else
if (len < (size_t) JANET_INTMAX_INT64) {
return janet_wrap_number(len);
} else {
janet_panicf("integer length %u too large", len);
}
#endif
}
Janet argv[1] = { x };
return janet_mcall("length", 1, argv);
}
@@ -728,13 +758,14 @@ void janet_putindex(Janet ds, int32_t index, Janet value) {
}
void janet_put(Janet ds, Janet key, Janet value) {
switch (janet_type(ds)) {
JanetType type = janet_type(ds);
switch (type) {
default:
janet_panicf("expected %T, got %v",
JANET_TFLAG_ARRAY | JANET_TFLAG_BUFFER | JANET_TFLAG_TABLE, ds);
case JANET_ARRAY: {
JanetArray *array = janet_unwrap_array(ds);
int32_t index = getter_checkint(key, INT32_MAX - 1);
int32_t index = getter_checkint(type, key, INT32_MAX - 1);
if (index >= array->count) {
janet_array_setcount(array, index + 1);
}
@@ -743,7 +774,7 @@ void janet_put(Janet ds, Janet key, Janet value) {
}
case JANET_BUFFER: {
JanetBuffer *buffer = janet_unwrap_buffer(ds);
int32_t index = getter_checkint(key, INT32_MAX - 1);
int32_t index = getter_checkint(type, key, INT32_MAX - 1);
if (!janet_checkint(value))
janet_panicf("can only put integers in buffers, got %v", value);
if (index >= buffer->count) {

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -40,7 +40,7 @@ void *janet_v_grow(void *v, int32_t increment, int32_t itemsize) {
/* Convert a buffer to normal allocated memory (forget capacity) */
void *janet_v_flattenmem(void *v, int32_t itemsize) {
int32_t *p;
char *p;
if (NULL == v) return NULL;
size_t size = (size_t) itemsize * janet_v__cnt(v);
p = janet_malloc(size);

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -138,7 +138,7 @@
vm_pcnext();\
}\
}
#define _vm_bitop_immediate(op, type1)\
#define _vm_bitop_immediate(op, type1, rangecheck, msg)\
{\
Janet op1 = stack[B];\
if (!janet_checktype(op1, JANET_NUMBER)) {\
@@ -147,13 +147,15 @@
stack[A] = janet_mcall(#op, 2, _argv);\
vm_checkgc_pcnext();\
} else {\
type1 x1 = (type1) janet_unwrap_integer(op1);\
stack[A] = janet_wrap_integer(x1 op CS);\
double y1 = janet_unwrap_number(op1);\
if (!rangecheck(y1)) { vm_commit(); janet_panicf("value %v out of range for " msg, op1); }\
type1 x1 = (type1) y1;\
stack[A] = janet_wrap_number((type1) (x1 op CS));\
vm_pcnext();\
}\
}
#define vm_bitop_immediate(op) _vm_bitop_immediate(op, int32_t);
#define vm_bitopu_immediate(op) _vm_bitop_immediate(op, uint32_t);
#define vm_bitop_immediate(op) _vm_bitop_immediate(op, int32_t, janet_checkintrange, "32-bit signed integers");
#define vm_bitopu_immediate(op) _vm_bitop_immediate(op, uint32_t, janet_checkuintrange, "32-bit unsigned integers");
#define _vm_binop(op, wrap)\
{\
Janet op1 = stack[B];\
@@ -170,14 +172,18 @@
}\
}
#define vm_binop(op) _vm_binop(op, janet_wrap_number)
#define _vm_bitop(op, type1)\
#define _vm_bitop(op, type1, rangecheck, msg)\
{\
Janet op1 = stack[B];\
Janet op2 = stack[C];\
if (janet_checktype(op1, JANET_NUMBER) && janet_checktype(op2, JANET_NUMBER)) {\
type1 x1 = (type1) janet_unwrap_integer(op1);\
int32_t x2 = janet_unwrap_integer(op2);\
stack[A] = janet_wrap_integer(x1 op x2);\
double y1 = janet_unwrap_number(op1);\
double y2 = janet_unwrap_number(op2);\
if (!rangecheck(y1)) { vm_commit(); janet_panicf("value %v out of range for " msg, op1); }\
if (!janet_checkintrange(y2)) { vm_commit(); janet_panicf("rhs must be valid 32-bit signed integer, got %f", op2); }\
type1 x1 = (type1) y1;\
int32_t x2 = (int32_t) y2;\
stack[A] = janet_wrap_number((type1) (x1 op x2));\
vm_pcnext();\
} else {\
vm_commit();\
@@ -185,8 +191,8 @@
vm_checkgc_pcnext();\
}\
}
#define vm_bitop(op) _vm_bitop(op, int32_t)
#define vm_bitopu(op) _vm_bitop(op, uint32_t)
#define vm_bitop(op) _vm_bitop(op, int32_t, janet_checkintrange, "32-bit signed integers")
#define vm_bitopu(op) _vm_bitop(op, uint32_t, janet_checkuintrange, "32-bit unsigned integers")
#define vm_compop(op) \
{\
Janet op1 = stack[B];\
@@ -918,7 +924,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) {
int32_t i;
for (i = 0; i < elen; ++i) {
int32_t inherit = fd->environments[i];
if (inherit == -1) {
if (inherit == -1 || inherit >= func->def->environments_length) {
JanetStackFrame *frame = janet_stack_frame(stack);
if (!frame->env) {
/* Lazy capture of current stack frame */
@@ -980,7 +986,7 @@ static JanetSignal run_vm(JanetFiber *fiber, Janet in) {
if (func->gc.flags & JANET_FUNCFLAG_TRACE) {
vm_do_trace(func, fiber->stacktop - fiber->stackstart, fiber->data + fiber->stackstart);
}
janet_stack_frame(stack)->pc = pc;
vm_commit();
if (janet_fiber_funcframe(fiber, func)) {
int32_t n = fiber->stacktop - fiber->stackstart;
janet_panicf("%v called with %d argument%s, expected %d",
@@ -1423,6 +1429,7 @@ static JanetSignal janet_continue_no_check(JanetFiber *fiber, Janet in, Janet *o
if (sig != JANET_SIGNAL_OK && !(child->flags & (1 << sig))) {
*out = in;
janet_fiber_set_status(fiber, sig);
fiber->last_value = child->last_value;
return sig;
}
/* Check if we need any special handling for certain opcodes */
@@ -1516,7 +1523,7 @@ JanetSignal janet_pcall(
fiber = janet_fiber(fun, 64, argc, argv);
}
if (f) *f = fiber;
if (!fiber) {
if (NULL == fiber) {
*out = janet_cstringv("arity mismatch");
return JANET_SIGNAL_ERROR;
}
@@ -1559,6 +1566,9 @@ int janet_init(void) {
janet_vm.scratch_len = 0;
janet_vm.scratch_cap = 0;
/* Sandbox flags */
janet_vm.sandbox_flags = 0;
/* Initialize registry */
janet_vm.registry = NULL;
janet_vm.registry_cap = 0;
@@ -1600,6 +1610,18 @@ int janet_init(void) {
return 0;
}
/* Disable some features at runtime with no way to re-enable them */
void janet_sandbox(uint32_t flags) {
janet_sandbox_assert(JANET_SANDBOX_SANDBOX);
janet_vm.sandbox_flags |= flags;
}
void janet_sandbox_assert(uint32_t forbidden_flags) {
if (forbidden_flags & janet_vm.sandbox_flags) {
janet_panic("operation forbidden by sandbox");
}
}
/* Clear all memory associated with the VM */
void janet_deinit(void) {
janet_clear_memory();

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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 Cygwin */
#if defined(__CYGWIN__)
#define JANET_CYGWIN 1
#endif
/* Check Unix */
#if defined(_AIX) \
|| defined(__APPLE__) /* Darwin */ \
@@ -87,6 +92,16 @@ extern "C" {
#define JANET_WINDOWS 1
#endif
/* Check if compiling with MSVC - else assume a GCC-like compiler by default */
#ifdef _MSC_VER
#define JANET_MSVC
#endif
/* Check Mingw 32-bit and 64-bit */
#ifdef __MINGW32__
#define JANET_MINGW
#endif
/* Check 64-bit vs 32-bit */
#if ((defined(__x86_64__) || defined(_M_X64)) \
&& (defined(JANET_POSIX) || defined(JANET_WINDOWS))) \
@@ -96,7 +111,8 @@ extern "C" {
|| (defined(__sparc__) && defined(__arch64__) || defined (__sparcv9)) /* BE */ \
|| defined(__s390x__) /* S390 64-bit (BE) */ \
|| (defined(__ppc64__) || defined(__PPC64__)) \
|| defined(__aarch64__) /* ARM 64-bit */
|| defined(__aarch64__) /* ARM 64-bit */ \
|| (defined(__riscv) && (__riscv_xlen == 64)) /* RISC-V 64-bit */
#define JANET_64 1
#else
#define JANET_32 1
@@ -166,11 +182,18 @@ extern "C" {
/* Enable or disable the FFI library. Currently, FFI only enabled on
* x86-64 operating systems. */
#ifndef JANET_NO_FFI
#if !defined(__EMSCRIPTEN__) && (defined(__x86_64__) || defined(_M_X64))
#if !defined(__EMSCRIPTEN__)
#define JANET_FFI
#endif
#endif
/* If FFI is enabled and FFI-JIT is not disabled... */
#ifdef JANET_FFI
#ifndef JANET_NO_FFI_JIT
#define JANET_FFI_JIT
#endif
#endif
/* Enable or disable the assembler. Enabled by default. */
#ifndef JANET_NO_ASSEMBLER
#define JANET_ASSEMBLER
@@ -257,10 +280,11 @@ extern "C" {
#ifndef JANET_NO_NANBOX
#ifdef JANET_32
#define JANET_NANBOX_32
#elif defined(__x86_64__) || defined(_WIN64)
#elif defined(__x86_64__) || defined(_WIN64) || defined(__riscv)
/* We will only enable nanboxing by default on 64 bit systems
* on x86. This is mainly because the approach is tied to the
* implicit 47 bit address space. */
* for x64 and risc-v. This is mainly because the approach is tied to the
* implicit 47 bit address space. Many arches allow/require this, but not all,
* and it requires cooperation from the OS. ARM should also work in many configurations. */
#define JANET_NANBOX_64
#endif
#endif
@@ -330,10 +354,9 @@ typedef struct JanetOSRWLock JanetOSRWLock;
#include <stddef.h>
#include <stdio.h>
/* What to do when out of memory */
#ifndef JANET_OUT_OF_MEMORY
#define JANET_OUT_OF_MEMORY do { fprintf(stderr, "janet out of memory\n"); exit(1); } while (0)
#define JANET_OUT_OF_MEMORY do { fprintf(stderr, "%s:%d - janet out of memory\n", __FILE__, __LINE__); exit(1); } while (0)
#endif
#ifdef JANET_BSD
@@ -425,6 +448,7 @@ typedef struct JanetReg JanetReg;
typedef struct JanetRegExt JanetRegExt;
typedef struct JanetMethod JanetMethod;
typedef struct JanetSourceMapping JanetSourceMapping;
typedef struct JanetSymbolMap JanetSymbolMap;
typedef struct JanetView JanetView;
typedef struct JanetByteView JanetByteView;
typedef struct JanetDictView JanetDictView;
@@ -543,6 +567,7 @@ typedef void *JanetAbstract;
#define JANET_STREAM_WRITABLE 0x400
#define JANET_STREAM_ACCEPTABLE 0x800
#define JANET_STREAM_UDPSERVER 0x1000
#define JANET_STREAM_TOCLOSE 0x10000
typedef enum {
JANET_ASYNC_EVENT_INIT,
@@ -843,12 +868,15 @@ JANET_API Janet janet_nanbox32_from_tagp(uint32_t tag, void *pointer);
#endif
JANET_API int janet_checkint(Janet x);
JANET_API int janet_checkuint(Janet x);
JANET_API int janet_checkint64(Janet x);
JANET_API int janet_checkuint64(Janet x);
JANET_API int janet_checksize(Janet x);
JANET_API JanetAbstract janet_checkabstract(Janet x, const JanetAbstractType *at);
#define janet_checkintrange(x) ((x) >= INT32_MIN && (x) <= INT32_MAX && (x) == (int32_t)(x))
#define janet_checkuintrange(x) ((x) >= 0 && (x) <= UINT32_MAX && (x) == (uint32_t)(x))
#define janet_checkint64range(x) ((x) >= JANET_INTMIN_DOUBLE && (x) <= JANET_INTMAX_DOUBLE && (x) == (int64_t)(x))
#define janet_checkuint64range(x) ((x) >= 0 && (x) <= JANET_INTMAX_DOUBLE && (x) == (uint64_t)(x))
#define janet_unwrap_integer(x) ((int32_t) janet_unwrap_number(x))
#define janet_wrap_integer(x) janet_wrap_number((int32_t)(x))
@@ -980,6 +1008,7 @@ struct JanetAbstractHead {
/* Some function definition flags */
#define JANET_FUNCDEF_FLAG_VARARG 0x10000
#define JANET_FUNCDEF_FLAG_NEEDSENV 0x20000
#define JANET_FUNCDEF_FLAG_HASSYMBOLMAP 0x40000
#define JANET_FUNCDEF_FLAG_HASNAME 0x80000
#define JANET_FUNCDEF_FLAG_HASSOURCE 0x100000
#define JANET_FUNCDEF_FLAG_HASDEFS 0x200000
@@ -995,6 +1024,14 @@ struct JanetSourceMapping {
int32_t column;
};
/* Symbol to slot mapping & lifetime structure. */
struct JanetSymbolMap {
uint32_t birth_pc;
uint32_t death_pc;
uint32_t slot_index;
const uint8_t *symbol;
};
/* A function definition. Contains information needed to instantiate closures. */
struct JanetFuncDef {
JanetGCObject gc;
@@ -1008,6 +1045,7 @@ struct JanetFuncDef {
JanetSourceMapping *sourcemap;
JanetString source;
JanetString name;
JanetSymbolMap *symbolmap;
int32_t flags;
int32_t slotcount; /* The amount of stack space required for the function */
@@ -1018,6 +1056,7 @@ struct JanetFuncDef {
int32_t bytecode_length;
int32_t environments_length;
int32_t defs_length;
int32_t symbolmap_length;
};
/* A function environment */
@@ -1093,6 +1132,8 @@ struct JanetAbstractType {
int32_t (*hash)(void *p, size_t len);
Janet(*next)(void *p, Janet key);
Janet(*call)(void *p, int32_t argc, Janet *argv);
size_t (*length)(void *p, size_t len);
JanetByteView(*bytes)(void *p, size_t len);
};
/* Some macros to let us add extra types to JanetAbstract types without
@@ -1110,7 +1151,9 @@ struct JanetAbstractType {
#define JANET_ATEND_COMPARE NULL,JANET_ATEND_HASH
#define JANET_ATEND_HASH NULL,JANET_ATEND_NEXT
#define JANET_ATEND_NEXT NULL,JANET_ATEND_CALL
#define JANET_ATEND_CALL
#define JANET_ATEND_CALL NULL,JANET_ATEND_LENGTH
#define JANET_ATEND_LENGTH NULL,JANET_ATEND_BYTES
#define JANET_ATEND_BYTES
struct JanetReg {
const char *name;
@@ -1439,6 +1482,7 @@ JANET_API void janet_ev_readchunk(JanetStream *stream, JanetBuffer *buf, int32_t
JANET_API void janet_ev_recv(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int flags);
JANET_API void janet_ev_recvchunk(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int flags);
JANET_API void janet_ev_recvfrom(JanetStream *stream, JanetBuffer *buf, int32_t nbytes, int flags);
JANET_API void janet_ev_connect(JanetStream *stream, int flags);
#endif
/* Write async to a stream */
@@ -1545,8 +1589,10 @@ JANET_API Janet janet_array_pop(JanetArray *array);
JANET_API Janet janet_array_peek(JanetArray *array);
/* Buffer functions */
#define JANET_BUFFER_FLAG_NO_REALLOC 0x10000
JANET_API JanetBuffer *janet_buffer(int32_t capacity);
JANET_API JanetBuffer *janet_buffer_init(JanetBuffer *buffer, int32_t capacity);
JANET_API JanetBuffer *janet_pointer_buffer_unsafe(void *memory, int32_t capacity, int32_t count);
JANET_API void janet_buffer_deinit(JanetBuffer *buffer);
JANET_API void janet_buffer_ensure(JanetBuffer *buffer, int32_t capacity, int32_t growth);
JANET_API void janet_buffer_setcount(JanetBuffer *buffer, int32_t count);
@@ -1645,6 +1691,7 @@ JANET_API void janet_table_clear(JanetTable *table);
JANET_API JanetFiber *janet_fiber(JanetFunction *callee, int32_t capacity, int32_t argc, const Janet *argv);
JANET_API JanetFiber *janet_fiber_reset(JanetFiber *fiber, JanetFunction *callee, int32_t argc, const Janet *argv);
JANET_API JanetFiberStatus janet_fiber_status(JanetFiber *fiber);
JANET_API int janet_fiber_can_resume(JanetFiber *fiber);
JANET_API JanetFiber *janet_current_fiber(void);
JANET_API JanetFiber *janet_root_fiber(void);
@@ -1759,6 +1806,27 @@ JANET_API Janet janet_mcall(const char *name, int32_t argc, Janet *argv);
JANET_API void janet_stacktrace(JanetFiber *fiber, Janet err);
JANET_API void janet_stacktrace_ext(JanetFiber *fiber, Janet err, const char *prefix);
/* Sandboxing API */
#define JANET_SANDBOX_SANDBOX 1
#define JANET_SANDBOX_SUBPROCESS 2
#define JANET_SANDBOX_NET_CONNECT 4
#define JANET_SANDBOX_NET_LISTEN 8
#define JANET_SANDBOX_FFI_DEFINE 16
#define JANET_SANDBOX_FS_WRITE 32
#define JANET_SANDBOX_FS_READ 64
#define JANET_SANDBOX_HRTIME 128
#define JANET_SANDBOX_ENV 256
#define JANET_SANDBOX_DYNAMIC_MODULES 512
#define JANET_SANDBOX_FS_TEMP 1024
#define JANET_SANDBOX_FFI_USE 2048
#define JANET_SANDBOX_FFI_JIT 4096
#define JANET_SANDBOX_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_ALL (UINT32_MAX)
JANET_API void janet_sandbox(uint32_t flags);
JANET_API void janet_sandbox_assert(uint32_t forbidden_flags);
/* Scratch Memory API */
typedef void (*JanetScratchFinalizer)(void *);
@@ -1817,7 +1885,7 @@ JANET_API Janet janet_resolve_core(const char *name);
/* sourcemaps only */
#define JANET_REG_S(JNAME, CNAME) {JNAME, CNAME, NULL, __FILE__, CNAME##_sourceline_}
#define JANET_FN_S(CNAME, USAGE, DOCSTRING) \
static int32_t CNAME##_sourceline_ = __LINE__; \
static const int32_t CNAME##_sourceline_ = __LINE__; \
Janet CNAME (int32_t argc, Janet *argv)
#define JANET_DEF_S(ENV, JNAME, VAL, DOC) \
janet_def_sm(ENV, JNAME, VAL, NULL, __FILE__, __LINE__)
@@ -1833,13 +1901,12 @@ JANET_API Janet janet_resolve_core(const char *name);
/* sourcemaps and docstrings */
#define JANET_REG_SD(JNAME, CNAME) {JNAME, CNAME, CNAME##_docstring_, __FILE__, CNAME##_sourceline_}
#define JANET_FN_SD(CNAME, USAGE, DOCSTRING) \
static int32_t CNAME##_sourceline_ = __LINE__; \
static const int32_t CNAME##_sourceline_ = __LINE__; \
static const char CNAME##_docstring_[] = USAGE "\n\n" DOCSTRING; \
Janet CNAME (int32_t argc, Janet *argv)
#define JANET_DEF_SD(ENV, JNAME, VAL, DOC) \
janet_def_sm(ENV, JNAME, VAL, DOC, __FILE__, __LINE__)
/* Choose defaults for source mapping and docstring based on config defs */
#if defined(JANET_NO_SOURCEMAPS) && defined(JANET_NO_DOCSTRINGS)
#define JANET_REG JANET_REG_
@@ -1907,6 +1974,7 @@ JANET_API JanetTable *janet_gettable(const Janet *argv, int32_t n);
JANET_API JanetStruct janet_getstruct(const Janet *argv, int32_t n);
JANET_API JanetString janet_getstring(const Janet *argv, int32_t n);
JANET_API const char *janet_getcstring(const Janet *argv, int32_t n);
JANET_API const char *janet_getcbytes(const Janet *argv, int32_t n);
JANET_API JanetSymbol janet_getsymbol(const Janet *argv, int32_t n);
JANET_API JanetKeyword janet_getkeyword(const Janet *argv, int32_t n);
JANET_API JanetBuffer *janet_getbuffer(const Janet *argv, int32_t n);
@@ -1936,6 +2004,7 @@ JANET_API JanetTuple janet_opttuple(const Janet *argv, int32_t argc, int32_t n,
JANET_API JanetStruct janet_optstruct(const Janet *argv, int32_t argc, int32_t n, JanetStruct dflt);
JANET_API JanetString janet_optstring(const Janet *argv, int32_t argc, int32_t n, JanetString dflt);
JANET_API const char *janet_optcstring(const Janet *argv, int32_t argc, int32_t n, const char *dflt);
JANET_API const char *janet_optcbytes(const Janet *argv, int32_t argc, int32_t n, const char *dflt);
JANET_API JanetSymbol janet_optsymbol(const Janet *argv, int32_t argc, int32_t n, JanetString dflt);
JANET_API JanetKeyword janet_optkeyword(const Janet *argv, int32_t argc, int32_t n, JanetString dflt);
JANET_API JanetFiber *janet_optfiber(const Janet *argv, int32_t argc, int32_t n, JanetFiber *dflt);
@@ -1984,6 +2053,7 @@ JANET_API int janet_cryptorand(uint8_t *out, size_t n);
JANET_API void janet_marshal_size(JanetMarshalContext *ctx, size_t value);
JANET_API void janet_marshal_int(JanetMarshalContext *ctx, int32_t value);
JANET_API void janet_marshal_int64(JanetMarshalContext *ctx, int64_t value);
JANET_API void janet_marshal_ptr(JanetMarshalContext *ctx, const void *value);
JANET_API void janet_marshal_byte(JanetMarshalContext *ctx, uint8_t value);
JANET_API void janet_marshal_bytes(JanetMarshalContext *ctx, const uint8_t *bytes, size_t len);
JANET_API void janet_marshal_janet(JanetMarshalContext *ctx, Janet x);
@@ -1993,6 +2063,7 @@ JANET_API void janet_unmarshal_ensure(JanetMarshalContext *ctx, size_t size);
JANET_API size_t janet_unmarshal_size(JanetMarshalContext *ctx);
JANET_API int32_t janet_unmarshal_int(JanetMarshalContext *ctx);
JANET_API int64_t janet_unmarshal_int64(JanetMarshalContext *ctx);
JANET_API void *janet_unmarshal_ptr(JanetMarshalContext *ctx);
JANET_API uint8_t janet_unmarshal_byte(JanetMarshalContext *ctx);
JANET_API void janet_unmarshal_bytes(JanetMarshalContext *ctx, uint8_t *dest, size_t len);
JANET_API Janet janet_unmarshal_janet(JanetMarshalContext *ctx);

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2022 Calvin Rose
* Copyright (c) 2023 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
@@ -33,6 +33,9 @@
#ifndef ENABLE_VIRTUAL_TERMINAL_PROCESSING
#define ENABLE_VIRTUAL_TERMINAL_PROCESSING 0x0004
#endif
#ifndef ENABLE_VIRTUAL_TERMINAL_INPUT
#define ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200
#endif
#endif
void janet_line_init();
@@ -144,8 +147,11 @@ static void setup_console_output(void) {
DWORD dwMode = 0;
GetConsoleMode(hOut, &dwMode);
dwMode |= ENABLE_VIRTUAL_TERMINAL_PROCESSING;
dwMode |= ENABLE_PROCESSED_OUTPUT;
SetConsoleMode(hOut, dwMode);
SetConsoleOutputCP(65001);
if (IsValidCodePage(65001)) {
SetConsoleOutputCP(65001);
}
}
/* Ansi terminal raw mode */
@@ -296,6 +302,7 @@ static char *sdup(const char *s) {
return memcpy(mem, s, len);
}
#ifndef _WIN32
static int curpos(void) {
char buf[32];
int cols, rows;
@@ -311,6 +318,7 @@ static int curpos(void) {
if (sscanf(buf + 2, "%d;%d", &rows, &cols) != 2) return -1;
return cols;
}
#endif
static int getcols(void) {
#ifdef _WIN32
@@ -540,7 +548,6 @@ static void kdeletew(void) {
refresh();
}
/* See tools/symchargen.c */
static int is_symbol_char_gen(uint8_t c) {
if (c & 0x80) return 1;
@@ -950,6 +957,7 @@ static int line() {
break;
#ifndef _WIN32
case 26: /* ctrl-z */
clearlines();
norawmode();
kill(getpid(), SIGSTOP);
rawmode();

View File

@@ -1,5 +1,5 @@
/*
* Copyright (c) 2021 Calvin Rose
* Copyright (c) 2023 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

View File

@@ -2,7 +2,7 @@
(var num-tests-passed 0)
(var num-tests-run 0)
(var suite-num 0)
(var suite-name 0)
(var start-time 0)
(def is-verbose (os/getenv "VERBOSE"))
@@ -14,9 +14,12 @@
(++ num-tests-run)
(when x (++ num-tests-passed))
(def str (string e))
(def frame (last (debug/stack (fiber/current))))
(def line-info (string/format "%s:%d"
(frame :source) (frame :source-line)))
(if x
(when is-verbose (eprintf "\e[32m✔\e[0m %s: %v" (describe e) x))
(eprintf "\e[31m✘\e[0m %s: %v" (describe e) x))
(when is-verbose (eprintf "\e[32m✔\e[0m %s: %s: %v" line-info (describe e) x))
(eprintf "\e[31m✘\e[0m %s: %s: %v" line-info (describe e) x))
x)
(defmacro assert-error
@@ -24,18 +27,30 @@
(def errsym (keyword (gensym)))
~(assert (= ,errsym (try (do ,;forms) ([_] ,errsym))) ,msg))
(defn check-compile-error
[form]
(def result (compile form))
(assert (table? result) (string/format "expected compilation error for %j, but compiled without error" form)))
(defmacro assert-no-error
[msg & forms]
(def errsym (keyword (gensym)))
~(assert (not= ,errsym (try (do ,;forms) ([_] ,errsym))) ,msg))
(defn start-suite [x]
(set suite-num x)
(defn start-suite [&opt x]
(default x (dyn :current-file))
(set suite-name
(cond
(number? x) (string x)
(string? x) (string/slice x
(length "test/suite-")
(- (inc (length ".janet"))))
(string x)))
(set start-time (os/clock))
(eprint "Starting suite " x "..."))
(eprint "Starting suite " suite-name "..."))
(defn end-suite []
(def delta (- (os/clock) start-time))
(eprinf "Finished suite %d in %.3f seconds - " suite-num delta)
(eprinf "Finished suite %s in %.3f seconds - " suite-name delta)
(eprint num-tests-passed " of " num-tests-run " tests passed.")
(if (not= num-tests-passed num-tests-run) (os/exit 1)))

81
test/suite-array.janet Normal file
View File

@@ -0,0 +1,81 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Array tests
# e05022f
(defn array=
"Check if two arrays are equal in an element by element comparison"
[a b]
(if (and (array? a) (array? b))
(= (apply tuple a) (apply tuple b))))
(assert (= (apply tuple @[1 2 3 4 5]) (tuple 1 2 3 4 5)) "array to tuple")
(def arr (array))
(array/push arr :hello)
(array/push arr :world)
(assert (array= arr @[:hello :world]) "array comparison")
(assert (array= @[1 2 3 4 5] @[1 2 3 4 5]) "array comparison 2")
(assert (array= @[:one :two :three :four :five]
@[:one :two :three :four :five]) "array comparison 3")
(assert (array= (array/slice @[1 2 3] 0 2) @[1 2]) "array/slice 1")
(assert (array= (array/slice @[0 7 3 9 1 4] 2 -2) @[3 9 1]) "array/slice 2")
# Array remove
# 687a3c9
(assert (deep= (array/remove @[1 2 3 4 5] 2) @[1 2 4 5]) "array/remove 1")
(assert (deep= (array/remove @[1 2 3 4 5] 2 2) @[1 2 5]) "array/remove 2")
(assert (deep= (array/remove @[1 2 3 4 5] 2 200) @[1 2]) "array/remove 3")
(assert (deep= (array/remove @[1 2 3 4 5] -3 200) @[1 2 3]) "array/remove 4")
# array/peek
(assert (nil? (array/peek @[])) "array/peek empty")
# array/fill
(assert (deep= (array/fill @[1 1] 2) @[2 2]) "array/fill 1")
# array/concat
(assert (deep= (array/concat @[1 2] @[3 4] 5 6) @[1 2 3 4 5 6]) "array/concat 1")
(def a @[1 2])
(assert (deep= (array/concat a a) @[1 2 1 2]) "array/concat self")
# array/insert
(assert (deep= (array/insert @[:a :a :a :a] 2 :b :b) @[:a :a :b :b :a :a]) "array/insert 1")
(assert (deep= (array/insert @[:a :b] -1 :c :d) @[:a :b :c :d]) "array/insert 2")
# array/remove
(assert-error "removal index 3 out of range [0,2]" (array/remove @[1 2] 3))
(assert-error "expected non-negative integer for argument n, got -1" (array/remove @[1 2] 1 -1))
# array/pop
(assert (= (array/pop @[1]) 1) "array/pop 1")
(assert (= (array/pop @[]) nil) "array/pop empty")
# Code coverage
(def a @[1])
(array/pop a)
(array/trim a)
(array/ensure @[1 1] 6 2)
(end-suite)

55
test/suite-asm.janet Normal file
View File

@@ -0,0 +1,55 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Assembly test
# Fibonacci sequence, implemented with naive recursion.
# a679f60
(def fibasm (asm '{
:arity 1
:bytecode [
(ltim 1 0 0x2) # $1 = $0 < 2
(jmpif 1 :done) # if ($1) goto :done
(lds 1) # $1 = self
(addim 0 0 -0x1) # $0 = $0 - 1
(push 0) # push($0), push argument for next function call
(call 2 1) # $2 = call($1)
(addim 0 0 -0x1) # $0 = $0 - 1
(push 0) # push($0)
(call 0 1) # $0 = call($1)
(add 0 0 2) # $0 = $0 + $2 (integers)
:done
(ret 0) # return $0
]
}))
(assert (= 0 (fibasm 0)) "fibasm 1")
(assert (= 1 (fibasm 1)) "fibasm 2")
(assert (= 55 (fibasm 10)) "fibasm 3")
(assert (= 6765 (fibasm 20)) "fibasm 4")
# dacbe29
(def f (asm (disasm (fn [x] (fn [y] (+ x y))))))
(assert (= ((f 10) 37) 47) "asm environment tables")
(end-suite)

907
test/suite-boot.janet Normal file
View File

@@ -0,0 +1,907 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Let
# 807f981
(assert (= (let [a 1 b 2] (+ a b)) 3) "simple let")
(assert (= (let [[a b] @[1 2]] (+ a b)) 3) "destructured let")
(assert (= (let [[a [c d] b] @[1 (tuple 4 3) 2]] (+ a b c d)) 10)
"double destructured let")
# Macros
# b305a7c
(defn dub [x] (+ x x))
(assert (= 2 (dub 1)) "defn macro")
(do
(defn trip [x] (+ x x x))
(assert (= 3 (trip 1)) "defn macro triple"))
(do
(var i 0)
(when true
(++ i)
(++ i)
(++ i)
(++ i)
(++ i)
(++ i))
(assert (= i 6) "when macro"))
# Add truthy? to core
# ded08b6
(assert (= true ;(map truthy? [0 "" true @{} {} [] '()])) "truthy values")
(assert (= false ;(map truthy? [nil false])) "non-truthy values")
## Polymorphic comparison -- Issue #272
# 81d301a42
# confirm polymorphic comparison delegation to primitive comparators:
(assert (= 0 (cmp 3 3)) "compare-primitive integers (1)")
(assert (= -1 (cmp 3 5)) "compare-primitive integers (2)")
(assert (= 1 (cmp "foo" "bar")) "compare-primitive strings")
(assert (= 0 (compare 1 1)) "compare integers (1)")
(assert (= -1 (compare 1 2)) "compare integers (2)")
(assert (= 1 (compare "foo" "bar")) "compare strings (1)")
(assert (compare< 1 2 3 4 5 6) "compare less than integers")
(assert (not (compare> 1 2 3 4 5 6)) "compare not greater than integers")
(assert (compare< 1.0 2.0 3.0 4.0 5.0 6.0) "compare less than reals")
(assert (compare> 6 5 4 3 2 1) "compare greater than integers")
(assert (compare> 6.0 5.0 4.0 3.0 2.0 1.0) "compare greater than reals")
(assert (not (compare< 6.0 5.0 4.0 3.0 2.0 1.0)) "compare less than reals")
(assert (compare<= 1 2 3 3 4 5 6) "compare less than or equal to integers")
(assert (compare<= 1.0 2.0 3.0 3.0 4.0 5.0 6.0)
"compare less than or equal to reals")
(assert (compare>= 6 5 4 4 3 2 1)
"compare greater than or equal to integers")
(assert (compare>= 6.0 5.0 4.0 4.0 3.0 2.0 1.0)
"compare greater than or equal to reals")
(assert (compare< 1.0 nil false true
(fiber/new (fn [] 1))
"hi"
(quote hello)
:hello
(array 1 2 3)
(tuple 1 2 3)
(table "a" "b" "c" "d")
(struct 1 2 3 4)
(buffer "hi")
(fn [x] (+ x x))
print) "compare type ordering")
# test polymorphic compare with 'objects' (table/setproto)
(def mynum
@{:type :mynum :v 0 :compare
(fn [self other]
(case (type other)
:number (cmp (self :v) other)
:table (when (= (get other :type) :mynum)
(cmp (self :v) (other :v)))))})
(let [n3 (table/setproto @{:v 3} mynum)]
(assert (= 0 (compare 3 n3)) "compare num to object (1)")
(assert (= -1 (compare n3 4)) "compare object to num (2)")
(assert (= 1 (compare (table/setproto @{:v 4} mynum) n3))
"compare object to object")
(assert (compare< 2 n3 4) "compare< poly")
(assert (compare> 4 n3 2) "compare> poly")
(assert (compare<= 2 3 n3 4) "compare<= poly")
(assert (compare= 3 n3 (table/setproto @{:v 3} mynum)) "compare= poly")
(assert (deep= (sorted @[4 5 n3 2] compare<) @[2 n3 4 5])
"polymorphic sort"))
# Add any? predicate to core
# 7478ad11
(assert (= nil (any? [])) "any? 1")
(assert (= nil (any? [false nil])) "any? 2")
(assert (= nil (any? [nil false])) "any? 3")
(assert (= 1 (any? [1])) "any? 4")
(assert (nan? (any? [nil math/nan nil])) "any? 5")
(assert (= true
(any? [nil nil false nil nil true nil nil nil nil false :a nil]))
"any? 6")
# Some higher order functions and macros
# 5e2de33
(def my-array @[1 2 3 4 5 6])
(assert (= (if-let [x (get my-array 5)] x) 6) "if-let 1")
(assert (= (if-let [y (get @{} :key)] 10 nil) nil) "if-let 2")
(assert (= (if-let [a my-array k (next a)] :t :f) :t) "if-let 3")
(assert (= (if-let [a my-array k (next a 5)] :t :f) :f) "if-let 4")
(assert (= (if-let [[a b] my-array] a) 1) "if-let 5")
(assert (= (if-let [{:a a :b b} {:a 1 :b 2}] b) 2) "if-let 6")
(assert (= (if-let [[a b] nil] :t :f) :f) "if-let 7")
# #1191
(var cnt 0)
(defmacro upcnt [] (++ cnt))
(assert (= (if-let [a true b true c true] nil (upcnt)) nil) "issue #1191")
(assert (= cnt 1) "issue #1191")
(assert (= 14 (sum (map inc @[1 2 3 4]))) "sum map")
(def myfun (juxt + - * /))
(assert (= [2 -2 2 0.5] (myfun 2)) "juxt")
# Case statements
# 5249228
(assert
(= :six (case (+ 1 2 3)
1 :one
2 :two
3 :three
4 :four
5 :five
6 :six
7 :seven
8 :eight
9 :nine)) "case macro")
(assert (= 7 (case :a :b 5 :c 6 :u 10 7)) "case with default")
# Testing the seq, tabseq, catseq, and loop macros
# 547529e
(def xs (apply tuple (seq [x :range [0 10] :when (even? x)]
(tuple (/ x 2) x))))
(assert (= xs '((0 0) (1 2) (2 4) (3 6) (4 8))) "seq macro 1")
# 624be87c9
(def xs (apply tuple (seq [x :down [8 -2] :when (even? x)]
(tuple (/ x 2) x))))
(assert (= xs '((4 8) (3 6) (2 4) (1 2) (0 0))) "seq macro 2")
# Looping idea
# 45f8db0
(def xs
(seq [x :in [-1 0 1] y :in [-1 0 1] :when (not= x y 0)] (tuple x y)))
(def txs (apply tuple xs))
(assert (= txs [[-1 -1] [-1 0] [-1 1] [0 -1] [0 1] [1 -1] [1 0] [1 1]])
"nested seq")
# 515891b03
(assert (deep= (tabseq [i :in (range 3)] i (* 3 i))
@{0 0 1 3 2 6}))
(assert (deep= (tabseq [i :in (range 3)] i)
@{}))
# ccd874fe4
(def xs (catseq [x :range [0 3]] [x x]))
(assert (deep= xs @[0 0 1 1 2 2]) "catseq")
# :range-to and :down-to
# e0c9910d8
(assert (deep= (seq [x :range-to [0 10]] x) (seq [x :range [0 11]] x))
"loop :range-to")
(assert (deep= (seq [x :down-to [10 0]] x) (seq [x :down [10 -1]] x))
"loop :down-to")
# 7880d7320
(def res @{})
(loop [[k v] :pairs @{1 2 3 4 5 6}]
(put res k v))
(assert (and
(= (get res 1) 2)
(= (get res 3) 4)
(= (get res 5) 6)) "loop :pairs")
# Issue #428
# 08a3687eb
(var result nil)
(defn f [] (yield {:a :ok}))
(assert-no-error "issue 428 1"
(loop [{:a x} :in (fiber/new f)] (set result x)))
(assert (= result :ok) "issue 428 2")
# Generators
# 184fe31e0
(def gen (generate [x :range [0 100] :when (pos? (% x 4))] x))
(var gencount 0)
(loop [x :in gen]
(++ gencount)
(assert (pos? (% x 4)) "generate in loop"))
(assert (= gencount 75) "generate loop count")
# Even and odd
# ff163a5ae
(assert (odd? 9) "odd? 1")
(assert (odd? -9) "odd? 2")
(assert (not (odd? 10)) "odd? 3")
(assert (not (odd? 0)) "odd? 4")
(assert (not (odd? -10)) "odd? 5")
(assert (not (odd? 1.1)) "odd? 6")
(assert (not (odd? -0.1)) "odd? 7")
(assert (not (odd? -1.1)) "odd? 8")
(assert (not (odd? -1.6)) "odd? 9")
(assert (even? 10) "even? 1")
(assert (even? -10) "even? 2")
(assert (even? 0) "even? 3")
(assert (not (even? 9)) "even? 4")
(assert (not (even? -9)) "even? 5")
(assert (not (even? 0.1)) "even? 6")
(assert (not (even? -0.1)) "even? 7")
(assert (not (even? -10.1)) "even? 8")
(assert (not (even? -10.6)) "even? 9")
# Map arities
# 25ded775a
(assert (deep= (map inc [1 2 3]) @[2 3 4]))
(assert (deep= (map + [1 2 3] [10 20 30]) @[11 22 33]))
(assert (deep= (map + [1 2 3] [10 20 30] [100 200 300]) @[111 222 333]))
(assert (deep= (map + [1 2 3] [10 20 30] [100 200 300] [1000 2000 3000])
@[1111 2222 3333]))
(assert (deep= (map +
[1 2 3] [10 20 30] [100 200 300] [1000 2000 3000]
[10000 20000 30000])
@[11111 22222 33333]))
# 77e62a2
(assert (deep= (map +
[1 2 3] [10 20 30] [100 200 300] [1000 2000 3000]
[10000 20000 30000] [100000 200000 300000])
@[111111 222222 333333]))
# Mapping uses the shortest sequence
# a69799aa4
(assert (deep= (map + [1 2 3 4] [10 20 30]) @[11 22 33]))
(assert (deep= (map + [1 2 3 4] [10 20 30] [100 200]) @[111 222]))
(assert (deep= (map + [1 2 3 4] [10 20 30] [100 200] [1000]) @[1111]))
# 77e62a2
(assert (deep= (map + [1 2 3 4] [10 20 30] [100 200] [1000] []) @[]))
# Variadic arguments to map-like functions
# 77e62a2
(assert (deep= (mapcat tuple [1 2 3 4] [5 6 7 8]) @[1 5 2 6 3 7 4 8]))
(assert (deep= (keep |(if (> $1 0) (/ $0 $1)) [1 2 3 4 5] [1 2 1 0 1])
@[1 1 3 5]))
(assert (= (count = [1 3 2 4 3 5 4 2 1] [1 2 3 4 5 4 3 2 1]) 4))
(assert (= (some not= (range 5) (range 5)) nil))
(assert (= (some = [1 2 3 4 5] [5 4 3 2 1]) true))
(assert (= (all = (range 5) (range 5)) true))
(assert (= (all not= [1 2 3 4 5] [5 4 3 2 1]) false))
# 4194374
(assert (= false (deep-not= [1] [1])) "issue #1149")
# Merge sort
# f5b29b8
# Imperative (and verbose) merge sort merge
(defn merge-sort
[xs ys]
(def ret @[])
(def xlen (length xs))
(def ylen (length ys))
(var i 0)
(var j 0)
# Main merge
(while (if (< i xlen) (< j ylen))
(def xi (get xs i))
(def yj (get ys j))
(if (< xi yj)
(do (array/push ret xi) (set i (+ i 1)))
(do (array/push ret yj) (set j (+ j 1)))))
# Push rest of xs
(while (< i xlen)
(def xi (get xs i))
(array/push ret xi)
(set i (+ i 1)))
# Push rest of ys
(while (< j ylen)
(def yj (get ys j))
(array/push ret yj)
(set j (+ j 1)))
ret)
(assert (apply <= (merge-sort @[1 3 5] @[2 4 6])) "merge sort merge 1")
(assert (apply <= (merge-sort @[1 2 3] @[4 5 6])) "merge sort merge 2")
(assert (apply <= (merge-sort @[1 3 5] @[2 4 6 6 6 9])) "merge sort merge 3")
(assert (apply <= (merge-sort '(1 3 5) @[2 4 6 6 6 9])) "merge sort merge 4")
(assert (deep= @[1 2 3 4 5] (sort @[5 3 4 1 2])) "sort 1")
(assert (deep= @[{:a 1} {:a 4} {:a 7}]
(sort-by |($ :a) @[{:a 4} {:a 7} {:a 1}])) "sort 2")
(assert (deep= @[1 2 3 4 5] (sorted [5 3 4 1 2])) "sort 3")
(assert (deep= @[{:a 1} {:a 4} {:a 7}]
(sorted-by |($ :a) [{:a 4} {:a 7} {:a 1}])) "sort 4")
# Sort function
# 2ca9300bf
(assert (deep=
(range 99)
(sort (mapcat (fn [[x y z]] [z y x]) (partition 3 (range 99)))))
"sort 5")
(assert (<= ;(sort (map (fn [x] (math/random)) (range 1000)))) "sort 6")
# And and or
# c16a9d846
(assert (= (and true true) true) "and true true")
(assert (= (and true false) false) "and true false")
(assert (= (and false true) false) "and false true")
(assert (= (and true true true) true) "and true true true")
(assert (= (and 0 1 2) 2) "and 0 1 2")
(assert (= (and 0 1 nil) nil) "and 0 1 nil")
(assert (= (and 1) 1) "and 1")
(assert (= (and) true) "and with no arguments")
(assert (= (and 1 true) true) "and with trailing true")
(assert (= (and 1 true 2) 2) "and with internal true")
(assert (= (or true true) true) "or true true")
(assert (= (or true false) true) "or true false")
(assert (= (or false true) true) "or false true")
(assert (= (or false false) false) "or false true")
(assert (= (or true true false) true) "or true true false")
(assert (= (or 0 1 2) 0) "or 0 1 2")
(assert (= (or nil 1 2) 1) "or nil 1 2")
(assert (= (or 1) 1) "or 1")
(assert (= (or) nil) "or with no arguments")
# And/or checks
# 6123c41f1
(assert (= false (and false false)) "and 1")
(assert (= false (or false false)) "or 1")
# Range
# a982f351d
(assert (deep= (range 10) @[0 1 2 3 4 5 6 7 8 9]) "range 1 argument")
(assert (deep= (range 5 10) @[5 6 7 8 9]) "range 2 arguments")
(assert (deep= (range 5 10 2) @[5 7 9]) "range 3 arguments")
# 11cd1279d
(assert (= (length (range 10)) 10) "(range 10)")
(assert (= (length (range 1 10)) 9) "(range 1 10)")
(assert (deep= @{:a 1 :b 2 :c 3} (zipcoll '[:a :b :c] '[1 2 3])) "zipcoll")
# bc8be266f
(def- a 100)
(assert (= a 100) "def-")
# bc8be266f
(assert (= :first
(match @[1 3 5]
@[x y z] :first
:second)) "match 1")
(def val1 :avalue)
(assert (= :second
(match val1
@[x y z] :first
:avalue :second
:third)) "match 2")
(assert (= 100
(match @[50 40]
@[x x] (* x 3)
@[x y] (+ x y 10)
0)) "match 3")
# Match checks
# 47e8f669f
(assert (= :hi (match nil nil :hi)) "match 1")
(assert (= :hi (match {:a :hi} {:a a} a)) "match 2")
(assert (= nil (match {:a :hi} {:a a :b b} a)) "match 3")
(assert (= nil (match [1 2] [a b c] a)) "match 4")
(assert (= 2 (match [1 2] [a b] b)) "match 5")
# db631097b
(assert (= [2 :a :b] (match [1 2 :a :b] [o & rest] rest)) "match 6")
(assert (= [] (match @[:a] @[x & r] r :fallback)) "match 7")
(assert (= :fallback (match @[1] @[x y & r] r :fallback)) "match 8")
(assert (= [1 2 3 4] (match @[1 2 3 4] @[x y z & r] [x y z ;r] :fallback))
"match 9")
# Test cases for #293
# d3b9b8d45
(assert (= :yes (match [1 2 3] [_ a _] :yes :no)) "match wildcard 1")
(assert (= :no (match [1 2 3] [__ a __] :yes :no)) "match wildcard 2")
(assert (= :yes (match [1 2 [1 2 3]] [_ a [_ _ _]] :yes :no))
"match wildcard 3")
(assert (= :yes (match [1 2 3] (_ (even? 2)) :yes :no)) "match wildcard 4")
(assert (= :yes (match {:a 1} {:a _} :yes :no)) "match wildcard 5")
(assert (= false (match {:a 1 :b 2 :c 3}
{:a a :b _ :c _ :d _} :no
{:a _ :b _ :c _} false
:no)) "match wildcard 6")
(assert (= nil (match {:a 1 :b 2 :c 3}
{:a a :b _ :c _ :d _} :no
{:a _ :b _ :c _} nil
:no)) "match wildcard 7")
# issue #529 - 602010600
(assert (= "t" (match [true nil] [true _] "t")) "match wildcard 8")
# quoted match test
# 425a0fcf0
(assert (= :yes (match 'john 'john :yes _ :nope)) "quoted literal match 1")
(assert (= :nope (match 'john ''john :yes _ :nope)) "quoted literal match 2")
# Some macros
# 7880d7320
(assert (= 2 (if-not 1 3 2)) "if-not 1")
(assert (= 3 (if-not false 3)) "if-not 2")
(assert (= 3 (if-not nil 3 2)) "if-not 3")
(assert (= nil (if-not true 3)) "if-not 4")
(assert (= 4 (unless false (+ 1 2 3) 4)) "unless")
# take
# 18da183ef
(assert (deep= (take 0 []) []) "take 1")
(assert (deep= (take 10 []) []) "take 2")
(assert (deep= (take 0 [1 2 3 4 5]) []) "take 3")
(assert (deep= (take 10 [1 2 3]) [1 2 3]) "take 4")
(assert (deep= (take -1 [:a :b :c]) [:c]) "take 5")
# 34019222c
(assert (deep= (take 3 (generate [x :in [1 2 3 4 5]] x)) @[1 2 3])
"take from fiber")
# NB: repeatedly resuming a fiber created with `generate` includes a `nil`
# as the final element. Thus a generate of 2 elements will create an array
# of 3.
(assert (= (length (take 4 (generate [x :in [1 2]] x))) 2)
"take from short fiber")
# take-until
# 18da183ef
(assert (deep= (take-until pos? @[]) []) "take-until 1")
(assert (deep= (take-until pos? @[1 2 3]) []) "take-until 2")
(assert (deep= (take-until pos? @[-1 -2 -3]) [-1 -2 -3]) "take-until 3")
(assert (deep= (take-until pos? @[-1 -2 3]) [-1 -2]) "take-until 4")
(assert (deep= (take-until pos? @[-1 1 -2]) [-1]) "take-until 5")
(assert (deep= (take-until |(= $ 115) "books") "book") "take-until 6")
(assert (deep= (take-until |(= $ 115) (generate [x :in "books"] x))
@[98 111 111 107]) "take-until from fiber")
# take-while
# 18da183ef
(assert (deep= (take-while neg? @[]) []) "take-while 1")
(assert (deep= (take-while neg? @[1 2 3]) []) "take-while 2")
(assert (deep= (take-while neg? @[-1 -2 -3]) [-1 -2 -3]) "take-while 3")
(assert (deep= (take-while neg? @[-1 -2 3]) [-1 -2]) "take-while 4")
(assert (deep= (take-while neg? @[-1 1 -2]) [-1]) "take-while 5")
(assert (deep= (take-while neg? (generate [x :in @[-1 1 -2]] x))
@[-1]) "take-while from fiber")
# drop
# 18da183ef
(assert (deep= (drop 0 []) []) "drop 1")
(assert (deep= (drop 10 []) []) "drop 2")
(assert (deep= (drop 0 [1 2 3 4 5]) [1 2 3 4 5]) "drop 3")
(assert (deep= (drop 10 [1 2 3]) []) "drop 4")
(assert (deep= (drop -1 [1 2 3]) [1 2]) "drop 5")
(assert (deep= (drop -10 [1 2 3]) []) "drop 6")
(assert (deep= (drop 1 "abc") "bc") "drop 7")
(assert (deep= (drop 10 "abc") "") "drop 8")
(assert (deep= (drop -1 "abc") "ab") "drop 9")
(assert (deep= (drop -10 "abc") "") "drop 10")
# drop-until
# 75dc08f
(assert (deep= (drop-until pos? @[]) []) "drop-until 1")
(assert (deep= (drop-until pos? @[1 2 3]) [1 2 3]) "drop-until 2")
(assert (deep= (drop-until pos? @[-1 -2 -3]) []) "drop-until 3")
(assert (deep= (drop-until pos? @[-1 -2 3]) [3]) "drop-until 4")
(assert (deep= (drop-until pos? @[-1 1 -2]) [1 -2]) "drop-until 5")
(assert (deep= (drop-until |(= $ 115) "books") "s") "drop-until 6")
# take-drop symmetry #1178
(def items-list ['abcde :abcde "abcde" @"abcde" [1 2 3 4 5] @[1 2 3 4 5]])
(each items items-list
(def len (length items))
(for i 0 (+ len 1)
(assert (deep= (take i items) (drop (- i len) items)) (string/format "take-drop symmetry %q %d" items i))
(assert (deep= (take (- i) items) (drop (- len i) items)) (string/format "take-drop symmetry %q %d" items i))))
(defn squares []
(coro
(var [a b] [0 1])
(forever (yield a) (+= a b) (+= b 2))))
(def sqr1 (squares))
(assert (deep= (take 10 sqr1) @[0 1 4 9 16 25 36 49 64 81]))
(assert (deep= (take 1 sqr1) @[100]) "take fiber next value")
(def sqr2 (drop 10 (squares)))
(assert (deep= (take 1 sqr2) @[100]) "drop fiber next value")
(def dict @{:a 1 :b 2 :c 3 :d 4 :e 5})
(def dict1 (take 2 dict))
(def dict2 (drop 2 dict))
(assert (= (length dict1) 2) "take dictionary")
(assert (= (length dict2) 3) "drop dictionary")
(assert (deep= (merge dict1 dict2) dict) "take-drop symmetry for dictionary")
# Comment macro
# issue #110 - 698e89aba
(comment 1)
(comment 1 2)
(comment 1 2 3)
(comment 1 2 3 4)
# comp should be variadic
# 5c83ebd75, 02ce3031
(assert (= 10 ((comp +) 1 2 3 4)) "variadic comp 1")
(assert (= 11 ((comp inc +) 1 2 3 4)) "variadic comp 2")
(assert (= 12 ((comp inc inc +) 1 2 3 4)) "variadic comp 3")
(assert (= 13 ((comp inc inc inc +) 1 2 3 4)) "variadic comp 4")
(assert (= 14 ((comp inc inc inc inc +) 1 2 3 4)) "variadic comp 5")
(assert (= 15 ((comp inc inc inc inc inc +) 1 2 3 4)) "variadic comp 6")
(assert (= 16 ((comp inc inc inc inc inc inc +) 1 2 3 4))
"variadic comp 7")
# Function shorthand
# 44e752d73
(assert (= (|(+ 1 2 3)) 6) "function shorthand 1")
(assert (= (|(+ 1 2 3 $) 4) 10) "function shorthand 2")
(assert (= (|(+ 1 2 3 $0) 4) 10) "function shorthand 3")
(assert (= (|(+ $0 $0 $0 $0) 4) 16) "function shorthand 4")
(assert (= (|(+ $ $ $ $) 4) 16) "function shorthand 5")
(assert (= (|4) 4) "function shorthand 6")
(assert (= (((|||4))) 4) "function shorthand 7")
(assert (= (|(+ $1 $1 $1 $1) 2 4) 16) "function shorthand 8")
(assert (= (|(+ $0 $1 $3 $2 $6) 0 1 2 3 4 5 6) 12) "function shorthand 9")
# 5f5147652
(assert (= (|(+ $0 $99) ;(range 100)) 99) "function shorthand 10")
# 655d4b3aa
(defn idx= [x y] (= (tuple/slice x) (tuple/slice y)))
# Simple take, drop, etc. tests.
(assert (idx= (take 10 (range 100)) (range 10)) "take 10")
(assert (idx= (drop 10 (range 100)) (range 10 100)) "drop 10")
# with-vars
# 6ceaf9d28
(var abc 123)
(assert (= 356 (with-vars [abc 456] (- abc 100))) "with-vars 1")
(assert-error "with-vars 2" (with-vars [abc 456] (error :oops)))
(assert (= abc 123) "with-vars 3")
# Top level unquote
# 2487162cc
(defn constantly
[]
(comptime (math/random)))
(assert (= (constantly) (constantly)) "comptime 1")
# issue #232 - b872ee024
(assert-error "arity issue in macro" (eval '(each [])))
# c6b639b93
(assert-error "comptime issue" (eval '(comptime (error "oops"))))
# 962cd7e5f
(var counter 0)
(when-with [x nil |$]
(++ counter))
(when-with [x 10 |$]
(+= counter 10))
(assert (= 10 counter) "when-with 1")
(if-with [x nil |$] (++ counter) (+= counter 10))
(if-with [x true |$] (+= counter 20) (+= counter 30))
(assert (= 40 counter) "if-with 1")
# a45509d28
(def a @[])
(eachk x [:a :b :c :d]
(array/push a x))
(assert (deep= (range 4) a) "eachk 1")
# issue 609 - 1fcaffe
(with-dyns [:err @""]
(tracev (def my-unique-var-name true))
(assert my-unique-var-name "tracev upscopes"))
# Prompts and Labels
# 59d288c
(assert (= 10 (label a (for i 0 10 (if (= i 5) (return a 10))))) "label 1")
(defn recur
[lab x y]
(when (= x y) (return lab :done))
(def res (label newlab (recur (or lab newlab) (+ x 1) y)))
(if lab :oops res))
(assert (= :done (recur nil 0 10)) "label 2")
(assert (= 10 (prompt :a (for i 0 10 (if (= i 5) (return :a 10)))))
"prompt 1")
(defn- inner-loop
[i]
(if (= i 5)
(return :a 10)))
(assert (= 10 (prompt :a (for i 0 10 (inner-loop i)))) "prompt 2")
(defn- inner-loop2
[i]
(try
(if (= i 5)
(error 10))
([err] (return :a err))))
(assert (= 10 (prompt :a (for i 0 10 (inner-loop2 i)))) "prompt 3")
# chr
# issue 304 - 77343e02e
(assert (= (chr "a") 97) "chr 1")
# Reduce2
# 3eb0927a2
(assert (= (reduce + 0 (range 1 10)) (reduce2 + (range 10))) "reduce2 1")
# 65379741f
(assert (= (reduce * 1 (range 2 10)) (reduce2 * (range 1 10))) "reduce2 2")
(assert (= nil (reduce2 * [])) "reduce2 3")
# Accumulate
# 3eb0927a2
(assert (deep= (accumulate + 0 (range 5)) @[0 1 3 6 10]) "accumulate 1")
(assert (deep= (accumulate2 + (range 5)) @[0 1 3 6 10]) "accumulate2 1")
# 65379741f
(assert (deep= @[] (accumulate2 + [])) "accumulate2 2")
(assert (deep= @[] (accumulate 0 + [])) "accumulate 2")
# in vs get regression
# issue #340 - b63a0796f
(assert (nil? (first @"")) "in vs get 1")
(assert (nil? (last @"")) "in vs get 1")
# index-of
# 259812314
(assert (= nil (index-of 10 [])) "index-of 1")
(assert (= nil (index-of 10 [1 2 3])) "index-of 2")
(assert (= 1 (index-of 2 [1 2 3])) "index-of 3")
(assert (= 0 (index-of :a [:a :b :c])) "index-of 4")
(assert (= nil (index-of :a {})) "index-of 5")
(assert (= :a (index-of :A {:a :A :b :B})) "index-of 6")
(assert (= :a (index-of :A @{:a :A :b :B})) "index-of 7")
(assert (= 0 (index-of (chr "a") "abc")) "index-of 8")
(assert (= nil (index-of (chr "a") "")) "index-of 9")
(assert (= nil (index-of 10 @[])) "index-of 10")
(assert (= nil (index-of 10 @[1 2 3])) "index-of 11")
# e78a3d1
# NOTE: These is a motivation for the has-value? and has-key? functions below
# returns false despite key present
(assert (= false (index-of 8 {true 7 false 8}))
"index-of corner key (false) 1")
(assert (= false (index-of 8 @{false 8}))
"index-of corner key (false) 2")
# still returns null
(assert (= nil (index-of 7 {false 8})) "index-of corner key (false) 3")
# has-value?
(assert (= false (has-value? [] "foo")) "has-value? 1")
(assert (= true (has-value? [4 7 1 3] 4)) "has-value? 2")
(assert (= false (has-value? [4 7 1 3] 22)) "has-value? 3")
(assert (= false (has-value? @[1 2 3] 4)) "has-value? 4")
(assert (= true (has-value? @[:a :b :c] :a)) "has-value? 5")
(assert (= false (has-value? {} :foo)) "has-value? 6")
(assert (= true (has-value? {:a :A :b :B} :A)) "has-value? 7")
(assert (= true (has-value? {:a :A :b :B} :A)) "has-value? 7")
(assert (= true (has-value? @{:a :A :b :B} :A)) "has-value? 8")
(assert (= true (has-value? "abc" (chr "a"))) "has-value? 9")
(assert (= false (has-value? "abc" "1")) "has-value? 10")
# weird true/false corner cases, should align with "index-of corner
# key {k}" cases
(assert (= true (has-value? {true 7 false 8} 8))
"has-value? corner key (false) 1")
(assert (= true (has-value? @{false 8} 8))
"has-value? corner key (false) 2")
(assert (= false (has-value? {false 8} 7))
"has-value? corner key (false) 3")
# has-key?
(do
(var test-has-key-auto 0)
(defn test-has-key [col key expected &keys {:name name}]
``Test that has-key has the outcome `expected`, and that if
the result is true, then ensure (in key) does not fail either``
(assert (boolean? expected))
(default name (string "has-key? " (++ test-has-key-auto)))
(assert (= expected (has-key? col key)) name)
(if
# guarenteed by `has-key?` to never fail
expected (in col key)
# if `has-key?` is false, then `in` should fail (for indexed types)
#
# For dictionary types, it should return nil
(let [[success retval] (protect (in col key))]
(def should-succeed (dictionary? col))
(assert
(= success should-succeed)
(string/format
"%s: expected (in col key) to %s, but got %q"
name (if expected "succeed" "fail") retval)))))
(test-has-key [] 0 false) # 1
(test-has-key [4 7 1 3] 2 true) # 2
(test-has-key [4 7 1 3] 22 false) # 3
(test-has-key @[1 2 3] 4 false) # 4
(test-has-key @[:a :b :c] 2 true) # 5
(test-has-key {} :foo false) # 6
(test-has-key {:a :A :b :B} :a true) # 7
(test-has-key {:a :A :b :B} :A false) # 8
(test-has-key @{:a :A :b :B} :a true) # 9
(test-has-key "abc" 1 true) # 10
(test-has-key "abc" 4 false) # 11
# weird true/false corner cases
#
# Tries to mimic the corresponding corner cases in has-value? and
# index-of, but with keys/values inverted
#
# in the first two cases (truthy? (get val col)) would have given false
# negatives
(test-has-key {7 true 8 false} 8 true :name
"has-key? corner value (false) 1")
(test-has-key @{8 false} 8 true :name
"has-key? corner value (false) 2")
(test-has-key @{8 false} 7 false :name
"has-key? corner value (false) 3"))
# Regression
# issue #463 - 7e7498350
(assert (= {:x 10} (|(let [x $] ~{:x ,x}) 10)) "issue 463")
# macex testing
# 7e7498350
(assert (deep= (macex1 '~{1 2 3 4}) '~{1 2 3 4}) "macex1 qq struct")
(assert (deep= (macex1 '~@{1 2 3 4}) '~@{1 2 3 4}) "macex1 qq table")
(assert (deep= (macex1 '~(1 2 3 4)) '~[1 2 3 4]) "macex1 qq tuple")
(assert (= :brackets (tuple/type (1 (macex1 '~[1 2 3 4]))))
"macex1 qq bracket tuple")
(assert (deep= (macex1 '~@[1 2 3 4 ,blah]) '~@[1 2 3 4 ,blah])
"macex1 qq array")
# Sourcemaps in threading macros
# b6175e429
(defn check-threading [macro expansion]
(def expanded (macex1 (tuple macro 0 '(x) '(y))))
(assert (= expanded expansion) (string macro " expansion value"))
(def smap-x (tuple/sourcemap (get expanded 1)))
(def smap-y (tuple/sourcemap expanded))
(def line first)
(defn column [t] (t 1))
(assert (not= smap-x [-1 -1]) (string macro " x sourcemap existence"))
(assert (not= smap-y [-1 -1]) (string macro " y sourcemap existence"))
(assert (or (< (line smap-x) (line smap-y))
(and (= (line smap-x) (line smap-y))
(< (column smap-x) (column smap-y))))
(string macro " relation between x and y sourcemap")))
(check-threading '-> '(y (x 0)))
(check-threading '->> '(y (x 0)))
# keep-syntax
# b6175e429
(let [brak '[1 2 3]
par '(1 2 3)]
(tuple/setmap brak 2 1)
(assert (deep= (keep-syntax brak @[1 2 3]) @[1 2 3])
"keep-syntax brackets ignore array")
(assert (= (keep-syntax! brak @[1 2 3]) '[1 2 3])
"keep-syntax! brackets replace array")
(assert (= (keep-syntax! par (map inc @[1 2 3])) '(2 3 4))
"keep-syntax! parens coerce array")
(assert (not= (keep-syntax! brak @[1 2 3]) '(1 2 3))
"keep-syntax! brackets not parens")
(assert (not= (keep-syntax! par @[1 2 3]) '[1 2 3])
"keep-syntax! parens not brackets")
(assert (= (tuple/sourcemap brak)
(tuple/sourcemap (keep-syntax! brak @[1 2 3])))
"keep-syntax! brackets source map")
(keep-syntax par brak)
(assert (not= (tuple/sourcemap brak) (tuple/sourcemap par))
"keep-syntax no mutate")
(assert (= (keep-syntax 1 brak) brak) "keep-syntax brackets ignore type"))
# Curenv
# 28439d822, f7c556e
(assert (= (curenv) (curenv 0)) "curenv 1")
(assert (= (table/getproto (curenv)) (curenv 1)) "curenv 2")
(assert (= nil (curenv 1000000)) "curenv 3")
(assert (= root-env (curenv 1)) "curenv 4")
# Import macro test
# a31e079f9
(assert-no-error "import macro 1" (macex '(import a :as b :fresh maybe)))
(assert (deep= ~(,import* "a" :as "b" :fresh maybe)
(macex '(import a :as b :fresh maybe))) "import macro 2")
# #477 walk preserving bracket type
# 0a1d902f4
(assert (= :brackets (tuple/type (postwalk identity '[])))
"walk square brackets 1")
(assert (= :brackets (tuple/type (walk identity '[])))
"walk square brackets 2")
# Issue #751
# 547fda6a4
(def t {:side false})
(assert (nil? (get-in t [:side :note])) "get-in with false value")
(assert (= (get-in t [:side :note] "dflt") "dflt")
"get-in with false value and default")
# Evaluate stream with `dofile`
# 9cc4e4812
(def [r w] (os/pipe))
(:write w "(setdyn :x 10)")
(:close w)
(def stream-env (dofile r))
(assert (= (stream-env :x) 10) "dofile stream 1")
# Test thaw and freeze
# 9cc0645a1
(def table-to-freeze @{:c 22 :b [1 2 3 4] :d @"test" :e "test2"})
(def table-to-freeze-with-inline-proto
@{:a @[1 2 3] :b @[1 2 3 4] :c 22 :d @"test" :e @"test2"})
(def struct-to-thaw
(struct/with-proto {:a [1 2 3]} :c 22 :b [1 2 3 4] :d "test" :e "test2"))
(table/setproto table-to-freeze @{:a @[1 2 3]})
(assert (deep= {:a [1 2 3] :b [1 2 3 4] :c 22 :d "test" :e "test2"}
(freeze table-to-freeze)))
(assert (deep= table-to-freeze-with-inline-proto (thaw table-to-freeze)))
(assert (deep= table-to-freeze-with-inline-proto (thaw struct-to-thaw)))
# Make sure Carriage Returns don't end up in doc strings
# e528b86
(assert (not (string/find "\r"
(get ((fiber/getenv (fiber/current)) 'cond)
:doc "")))
"no \\r in doc strings")
# cff718f37
(var counter 0)
(def thunk (delay (++ counter)))
(assert (= (thunk) 1) "delay 1")
(assert (= counter 1) "delay 2")
(assert (= (thunk) 1) "delay 3")
(assert (= counter 1) "delay 4")
# maclintf
(def env (table/clone (curenv)))
((compile '(defmacro foo [] (maclintf :strict "oops")) env :anonymous))
(def lints @[])
(compile (tuple/setmap '(foo) 1 2) env :anonymous lints)
(assert (deep= lints @[[:strict 1 2 "oops"]]) "maclintf 1")
(def env (table/clone (curenv)))
((compile '(defmacro foo [& body] (maclintf :strict "foo-oops") ~(do ,;body)) env :anonymous))
((compile '(defmacro bar [] (maclintf :strict "bar-oops")) env :anonymous))
(def lints @[])
# Compile (foo (bar)), but with explicit source map values
(def bar-invoke (tuple/setmap '(bar) 3 4))
(compile (tuple/setmap ~(foo ,bar-invoke) 1 2) env :anonymous lints)
(assert (deep= lints @[[:strict 1 2 "foo-oops"]
[:strict 3 4 "bar-oops"]])
"maclintf 2")
(end-suite)

120
test/suite-buffer.janet Normal file
View File

@@ -0,0 +1,120 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Buffer blitting
# 16ebb1118
(def b (buffer/new-filled 100))
(buffer/bit-set b 100)
(buffer/bit-clear b 100)
(assert (zero? (sum b)) "buffer bit set and clear")
(assert (= false (buffer/bit b 101)) "bit get false")
(buffer/bit-toggle b 101)
(assert (= true (buffer/bit b 101)) "bit get true")
(assert (= 32 (sum b)) "buffer bit set and clear")
(assert-error "invalid bit index 1000" (buffer/bit-toggle b 1000))
(def b2 @"hello world")
(buffer/blit b2 "joyto ")
(assert (= (string b2) "joyto world") "buffer/blit 1")
(buffer/blit b2 "joyto" 6)
(assert (= (string b2) "joyto joyto") "buffer/blit 2")
(buffer/blit b2 "abcdefg" 5 6)
(assert (= (string b2) "joytogjoyto") "buffer/blit 3")
# buffer/push
(assert (deep= (buffer/push @"AA" @"BB") @"AABB") "buffer/push buffer")
(assert (deep= (buffer/push @"AA" 66 66) @"AABB") "buffer/push int")
(def b @"AA")
(assert (deep= (buffer/push b b) @"AAAA") "buffer/push buffer self")
# buffer/push-byte
(assert (deep= (buffer/push-byte @"AA" 66) @"AAB") "buffer/push-byte")
(assert-error "bad slot #1, expected 32 bit signed integer" (buffer/push-byte @"AA" :flap))
# Buffer push word
# e755f9830
(def b3 @"")
(buffer/push-word b3 0xFF 0x11)
(assert (= 8 (length b3)) "buffer/push-word 1")
(assert (= "\xFF\0\0\0\x11\0\0\0" (string b3)) "buffer/push-word 2")
(buffer/clear b3)
(buffer/push-word b3 0xFFFFFFFF 0x1100)
(assert (= 8 (length b3)) "buffer/push-word 3")
(assert (= "\xFF\xFF\xFF\xFF\0\x11\0\0" (string b3)) "buffer/push-word 4")
(assert-error "cannot convert 0.5 to machine word" (buffer/push-word @"" 0.5))
# Buffer push string
# 175925207
(def b4 (buffer/new-filled 10 0))
(buffer/push-string b4 b4)
(assert (= "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" (string b4))
"buffer/push-buffer 1")
(def b5 @"123")
(buffer/push-string b5 "456" @"789")
(assert (= "123456789" (string b5)) "buffer/push-buffer 2")
# some tests for buffer/format
# 029394d
(assert (= (string (buffer/format @"" "pi = %6.3f" math/pi)) "pi = 3.142")
"%6.3f")
(assert (= (string (buffer/format @"" "pi = %+6.3f" math/pi)) "pi = +3.142")
"%6.3f")
(assert (= (string (buffer/format @"" "pi = %40.20g" math/pi))
"pi = 3.141592653589793116") "%6.3f")
(assert (= (string (buffer/format @"" "🐼 = %6.3f" math/pi)) "🐼 = 3.142")
"UTF-8")
(assert (= (string (buffer/format @"" "π = %.8g" math/pi)) "π = 3.1415927")
"π")
(assert (= (string (buffer/format @"" "\xCF\x80 = %.8g" math/pi))
"\xCF\x80 = 3.1415927") "\xCF\x80")
# Regression #301
# a3d4ecddb
(def b (buffer/new-filled 128 0x78))
(assert (= 38 (length (buffer/blit @"" b -1 90))) "buffer/blit 1")
(def a @"abcdefghijklm")
(assert (deep= @"abcde" (buffer/blit @"" a -1 0 5)) "buffer/blit 2")
(assert (deep= @"bcde" (buffer/blit @"" a -1 1 5)) "buffer/blit 3")
(assert (deep= @"cde" (buffer/blit @"" a -1 2 5)) "buffer/blit 4")
(assert (deep= @"de" (buffer/blit @"" a -1 3 5)) "buffer/blit 5")
# buffer/push-at
# c55d93512
(assert (deep= @"abc456" (buffer/push-at @"abc123" 3 "456"))
"buffer/push-at 1")
(assert (deep= @"abc456789" (buffer/push-at @"abc123" 3 "456789"))
"buffer/push-at 2")
(assert (deep= @"abc423" (buffer/push-at @"abc123" 3 "4"))
"buffer/push-at 3")
# 4782a76
(assert (= 10 (do (var x 10) (def y x) (++ x) y)) "no invalid aliasing")
(end-suite)

View File

@@ -1,4 +1,4 @@
# Copyright (c) 2022 Calvin Rose & contributors
# Copyright (c) 2023 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
@@ -19,25 +19,26 @@
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite 13)
(start-suite)
(assert (deep= (tabseq [i :in (range 3)] i (* 3 i))
@{0 0 1 3 2 6}))
# Tuple types
# c6edf03ae
(assert (= (tuple/type '(1 2 3)) :parens) "normal tuple")
(assert (= (tuple/type [1 2 3]) :parens) "normal tuple 1")
(assert (= (tuple/type '[1 2 3]) :brackets) "bracketed tuple 2")
(assert (= (tuple/type (-> '(1 2 3) marshal unmarshal)) :parens)
"normal tuple marshalled/unmarshalled")
(assert (= (tuple/type (-> '[1 2 3] marshal unmarshal)) :brackets)
"normal tuple marshalled/unmarshalled")
(assert (deep= (tabseq [i :in (range 3)] i)
@{}))
(def- sym-prefix-peg
(peg/compile
~{:symchar (+ (range "\x80\xff" "AZ" "az" "09") (set "!$%&*+-./:<?=>@^_"))
:anchor (drop (cmt ($) ,|(= $ 0)))
:cap (* (+ (> -1 (not :symchar)) :anchor) (* ($) '(some :symchar)))
:recur (+ :cap (> -1 :recur))
:main (> -1 :recur)}))
(assert (deep= (peg/match sym-prefix-peg @"123" 3) @[0 "123"]) "peg lookback")
(assert (deep= (peg/match sym-prefix-peg @"1234" 4) @[0 "1234"]) "peg lookback 2")
(assert (deep= (peg/replace-all '(* (<- 1) 1 (backmatch)) "xxx" "aba cdc efa") @"xxx xxx efa") "peg replace-all 1")
# Dynamic bindings
# 7918add47, 513d551d
(setdyn :a 10)
(assert (= 40 (with-dyns [:a 25 :b 15] (+ (dyn :a) (dyn :b)))) "dyn usage 1")
(assert (= 10 (dyn :a)) "dyn usage 2")
(assert (= nil (dyn :b)) "dyn usage 3")
(setdyn :a 100)
(assert (= 100 (dyn :a)) "dyn usage 4")
(end-suite)

34
test/suite-cfuns.janet Normal file
View File

@@ -0,0 +1,34 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Inline 3 argument get
# a1ea62a
(assert (= 10 (do (var a 10) (set a (get '{} :a a)))) "inline get 1")
# Regression #24
# f28477649
(def t (put @{} :hi 1))
(assert (deep= t @{:hi 1}) "regression #24")
(end-suite)

77
test/suite-compile.janet Normal file
View File

@@ -0,0 +1,77 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Regression Test
# 0378ba78
(assert (= 1 (((compile '(fn [] 1) @{})))) "regression test")
# Fix a compiler bug in the do special form
# 3e1e2585
(defn myfun [x]
(var a 10)
(set a (do
(def y x)
(if x 8 9))))
(assert (= (myfun true) 8) "check do form regression")
(assert (= (myfun false) 9) "check do form regression")
# Check x:digits: works as symbol and not a hex number
# 5baf70f4
(def x1 100)
(assert (= x1 100) "x1 as symbol")
(def X1 100)
(assert (= X1 100) "X1 as symbol")
# Edge case should cause old compilers to fail due to
# if statement optimization
# 17283241
(var var-a 1)
(var var-b (if false 2 (string "hello")))
(assert (= var-b "hello") "regression 1")
# d28925fda
(assert (= (string '()) (string [])) "empty bracket tuple literal")
# Bracket tuple issue
# 340a6c4
(let [do 3]
(assert (= [3 1 2 3] [do 1 2 3]) "bracket tuples are never special forms"))
(assert (= ~(,defn 1 2 3) [defn 1 2 3]) "bracket tuples are never macros")
(assert (= ~(,+ 1 2 3) [+ 1 2 3]) "bracket tuples are never function calls")
# Crash issue #1174 - bad debug info
# e97299f
(defn crash []
(debug/stack (fiber/current)))
(do
(math/random)
(defn foo [_]
(crash)
1)
(foo 0)
10)
(end-suite)

143
test/suite-corelib.janet Normal file
View File

@@ -0,0 +1,143 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# ac50f62
(assert (= 10 (+ 1 2 3 4)) "addition")
(assert (= -8 (- 1 2 3 4)) "subtraction")
(assert (= 24 (* 1 2 3 4)) "multiplication")
# d6967a5
(assert (= 4 (blshift 1 2)) "left shift")
(assert (= 1 (brshift 4 2)) "right shift")
# unsigned shift
(assert (= 32768 (brushift 0x80000000 16)) "right shift unsigned 1")
(assert-error "right shift unsigned 2" (= -32768 (brshift 0x80000000 16)))
(assert (= -1 (brshift -1 16)) "right shift unsigned 3")
# non-immediate forms
(assert (= 32768 (brushift 0x80000000 (+ 0 16))) "right shift unsigned non-immediate")
(assert-error "right shift non-immediate" (= -32768 (brshift 0x80000000 (+ 0 16))))
(assert (= -1 (brshift -1 (+ 0 16))) "right shift non-immediate 2")
(assert (= 32768 (blshift 1 (+ 0 15))) "left shift non-immediate")
# 7e46ead
(assert (< 1 2 3 4 5 6) "less than integers")
(assert (< 1.0 2.0 3.0 4.0 5.0 6.0) "less than reals")
(assert (> 6 5 4 3 2 1) "greater than integers")
(assert (> 6.0 5.0 4.0 3.0 2.0 1.0) "greater than reals")
(assert (<= 1 2 3 3 4 5 6) "less than or equal to integers")
(assert (<= 1.0 2.0 3.0 3.0 4.0 5.0 6.0) "less than or equal to reals")
(assert (>= 6 5 4 4 3 2 1) "greater than or equal to integers")
(assert (>= 6.0 5.0 4.0 4.0 3.0 2.0 1.0) "greater than or equal to reals")
(assert (= 7 (% 20 13)) "modulo 1")
(assert (= -7 (% -20 13)) "modulo 2")
(assert (< 1.0 nil false true
(fiber/new (fn [] 1))
"hi"
(quote hello)
:hello
(array 1 2 3)
(tuple 1 2 3)
(table "a" "b" "c" "d")
(struct 1 2 3 4)
(buffer "hi")
(fn [x] (+ x x))
print) "type ordering")
# b305a7c9b
(assert (= (string (buffer "123" "456")) (string @"123456")) "buffer literal")
# 277117165
(assert (= (get {} 1) nil) "get nil from empty struct")
(assert (= (get @{} 1) nil) "get nil from empty table")
(assert (= (get {:boop :bap} :boop) :bap) "get non nil from struct")
(assert (= (get @{:boop :bap} :boop) :bap) "get non nil from table")
(assert (= (get @"\0" 0) 0) "get non nil from buffer")
(assert (= (get @"\0" 1) nil) "get nil from buffer oob")
(assert (put @{} :boop :bap) "can add to empty table")
(assert (put @{1 3} :boop :bap) "can add to non-empty table")
# 7e46ead
(assert (= 7 (bor 3 4)) "bit or")
(assert (= 0 (band 3 4)) "bit and")
# f41dab8
(assert (= 0xFF (bxor 0x0F 0xF0)) "bit xor")
(assert (= 0xF0 (bxor 0xFF 0x0F)) "bit xor 2")
# Some testing for not=
# 08f6c642d
(assert (not= 1 1 0) "not= 1")
(assert (not= 0 1 1) "not= 2")
# Check if abstract test works
# d791077e2
(assert (abstract? stdout) "abstract? stdout")
(assert (abstract? stdin) "abstract? stdin")
(assert (abstract? stderr) "abstract? stderr")
(assert (not (abstract? nil)) "not abstract? nil")
(assert (not (abstract? 1)) "not abstract? 1")
(assert (not (abstract? 3)) "not abstract? 3")
(assert (not (abstract? 5)) "not abstract? 5")
# Module path expansion
# ff3bb6627
(setdyn :current-file "some-dir/some-file")
(defn test-expand [path temp]
(string (module/expand-path path temp)))
(assert (= (test-expand "abc" ":cur:/:all:") "some-dir/abc")
"module/expand-path 1")
(assert (= (test-expand "./abc" ":cur:/:all:") "some-dir/abc")
"module/expand-path 2")
(assert (= (test-expand "abc/def.txt" ":cur:/:name:") "some-dir/def.txt")
"module/expand-path 3")
(assert (= (test-expand "abc/def.txt" ":cur:/:dir:/sub/:name:")
"some-dir/abc/sub/def.txt") "module/expand-path 4")
# fc46030e7
(assert (= (test-expand "/abc/../def.txt" ":all:") "/def.txt")
"module/expand-path 5")
(assert (= (test-expand "abc/../def.txt" ":all:") "def.txt")
"module/expand-path 6")
(assert (= (test-expand "../def.txt" ":all:") "../def.txt")
"module/expand-path 7")
(assert (= (test-expand "../././././abcd/../def.txt" ":all:") "../def.txt")
"module/expand-path 8")
# module/expand-path regression
# issue #143 - e0fe8476a
(with-dyns [:syspath ".janet/.janet"]
(assert (= (string (module/expand-path "hello" ":sys:/:all:.janet"))
".janet/.janet/hello.janet") "module/expand-path 1"))
# int?
(assert (int? 1) "int? 1")
(assert (int? -1) "int? -1")
(assert (not (int? true)) "int? true")
(assert (not (int? 3.14)) "int? 3.14")
(assert (not (int? 8589934592)) "int? 8589934592")
# memcmp
(assert (= (memcmp "123helloabcd" "1234helloabc" 5 3 4) 0) "memcmp 1")
(assert (< (memcmp "123hellaabcd" "1234helloabc" 5 3 4) 0) "memcmp 2")
(assert (> (memcmp "123helloabcd" "1234hellaabc" 5 3 4) 0) "memcmp 3")
(assert-error "invalid offset-a: 1" (memcmp "a" "b" 1 1 0))
(assert-error "invalid offset-b: 1" (memcmp "a" "b" 1 0 1))
(end-suite)

34
test/suite-debug.janet Normal file
View File

@@ -0,0 +1,34 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Simple function break
# a8afc5b81
(debug/fbreak map 1)
(def f (fiber/new (fn [] (map inc [1 2 3])) :a))
(resume f)
(assert (= :debug (fiber/status f)) "debug/fbreak")
(debug/unfbreak map 1)
(map inc [1 2 3])
(end-suite)

View File

@@ -1,4 +1,4 @@
# Copyright (c) 2021 Calvin Rose & contributors
# Copyright (c) 2023 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
@@ -19,45 +19,58 @@
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite 9)
(start-suite)
# Subprocess
# 5e1a8c86f
(def janet (dyn :executable))
# Subprocess should inherit the "RUN" parameter for fancy testing
(def run (filter next (string/split " " (os/getenv "SUBRUN" ""))))
(repeat 10
(let [p (os/spawn [janet "-e" `(print "hello")`] :p {:out :pipe})]
(let [p (os/spawn [;run janet "-e" `(print "hello")`] :p {:out :pipe})]
(os/proc-wait p)
(def x (:read (p :out) :all))
(assert (deep= "hello" (string/trim x)) "capture stdout from os/spawn pre close."))
(assert (deep= "hello" (string/trim x))
"capture stdout from os/spawn pre close."))
(let [p (os/spawn [janet "-e" `(print "hello")`] :p {:out :pipe})]
(let [p (os/spawn [;run janet "-e" `(print "hello")`] :p {:out :pipe})]
(def x (:read (p :out) 1024))
(os/proc-wait p)
(assert (deep= "hello" (string/trim x)) "capture stdout from os/spawn post close."))
(assert (deep= "hello" (string/trim x))
"capture stdout from os/spawn post close."))
(let [p (os/spawn [janet "-e" `(file/read stdin :line)`] :px {:in :pipe})]
(let [p (os/spawn [;run janet "-e" `(file/read stdin :line)`] :px
{:in :pipe})]
(:write (p :in) "hello!\n")
(assert-no-error "pipe stdin to process" (os/proc-wait p))))
(let [p (os/spawn [janet "-e" `(print (file/read stdin :line))`] :px {:in :pipe :out :pipe})]
(let [p (os/spawn [;run janet "-e" `(print (file/read stdin :line))`] :px
{:in :pipe :out :pipe})]
(:write (p :in) "hello!\n")
(def x (:read (p :out) 1024))
(assert-no-error "pipe stdin to process 2" (os/proc-wait p))
(assert (= "hello!" (string/trim x)) "round trip pipeline in process"))
(let [p (os/spawn [janet "-e" `(do (ev/sleep 30) (os/exit 24)`] :p)]
(let [p (os/spawn [;run janet "-e" `(do (ev/sleep 30) (os/exit 24)`] :p)]
(os/proc-kill p)
(def retval (os/proc-wait p))
(assert (not= retval 24) "Process was *not* terminated by parent"))
# Parallel subprocesses
(let [p (os/spawn [;run janet "-e" `(do (ev/sleep 30) (os/exit 24)`] :p)]
(os/proc-kill p false :term)
(def retval (os/proc-wait p))
(assert (not= retval 24) "Process was *not* terminated by parent"))
# Parallel subprocesses
# 5e1a8c86f
(defn calc-1
"Run subprocess, read from stdout, then wait on subprocess."
[code]
(let [p (os/spawn [janet "-e" (string `(printf "%j" ` code `)`)] :px {:out :pipe})]
(let [p (os/spawn [;run janet "-e" (string `(printf "%j" ` code `)`)] :px
{:out :pipe})]
(os/proc-wait p)
(def output (:read (p :out) :all))
(parse output)))
@@ -71,9 +84,13 @@
@[10 26 42]) "parallel subprocesses 1")
(defn calc-2
"Run subprocess, wait on subprocess, then read from stdout. Read only up to 10 bytes instead of :all"
``
Run subprocess, wait on subprocess, then read from stdout. Read only up
to 10 bytes instead of :all
``
[code]
(let [p (os/spawn [janet "-e" (string `(printf "%j" ` code `)`)] :px {:out :pipe})]
(let [p (os/spawn [;run janet "-e" (string `(printf "%j" ` code `)`)] :px
{:out :pipe})]
(def output (:read (p :out) 10))
(os/proc-wait p)
(parse output)))
@@ -87,36 +104,54 @@
@[10 26 42]) "parallel subprocesses 2")
# File piping
# a1cc5ca04
(assert-no-error "file writing 1"
(with [f (file/temp)]
(os/execute [janet "-e" `(repeat 20 (print :hello))`] :p {:out f})))
(os/execute [;run janet "-e" `(repeat 20 (print :hello))`] :p {:out f})))
(assert-no-error "file writing 2"
(with [f (file/open "unique.txt" :w)]
(os/execute [janet "-e" `(repeat 20 (print :hello))`] :p {:out f})
(os/execute [;run janet "-e" `(repeat 20 (print :hello))`] :p {:out f})
(file/flush f)))
# Issue #593
# a1cc5ca04
(assert-no-error "file writing 3"
(def outfile (file/open "unique.txt" :w))
(os/execute [janet "-e" "(pp (seq [i :range (1 10)] i))"] :p {:out outfile})
(os/execute [;run janet "-e" "(pp (seq [i :range (1 10)] i))"] :p
{:out outfile})
(file/flush outfile)
(file/close outfile)
(os/rm "unique.txt"))
# Ensure that the stream created by os/open works
# each-line iterator
# 70f13f1
(assert-no-error "file/lines iterator"
(def outstream (os/open "unique.txt" :wct))
(def buf1 "123\n456\n")
(defer (:close outstream)
(:write outstream buf1))
(var buf2 "")
(with [f (file/open "unique.txt" :r)]
(each line (file/lines f)
(set buf2 (string buf2 line))))
(assert (= buf1 buf2) "file/lines iterator")
(os/rm "unique.txt"))
# Ensure that the stream created by os/open works
# e8a86013d
(assert-no-error "File writing 4.1"
(def outstream (os/open "unique.txt" :wct))
(defer (:close outstream)
(:write outstream "123\n")
(:write outstream "456\n"))
# Cast to string to enable comparison
(assert (= "123\n456\n" (string (slurp "unique.txt"))) "File writing 4.2")
(assert (= "123\n456\n" (string (slurp "unique.txt")))
"File writing 4.2")
(os/rm "unique.txt"))
# Test that the stream created by os/open can be read from
# 8d8a6534e
(comment
(assert-no-error "File reading 1.1"
(def outstream (os/open "unique.txt" :wct))
@@ -126,17 +161,25 @@
(def outstream (os/open "unique.txt" :r))
(defer (:close outstream)
(assert (= "123\n456\n" (string (:read outstream :all))) "File reading 1.2"))
(assert (= "123\n456\n" (string (:read outstream :all)))
"File reading 1.2"))
(os/rm "unique.txt")))
# ev/gather
# ev/gather
# 4f2d1cdc0
(assert (deep= @[1 2 3] (ev/gather 1 2 3)) "ev/gather 1")
(assert (deep= @[] (ev/gather)) "ev/gather 2")
(assert-error "ev/gather 3" (ev/gather 1 2 (error 3)))
# Net testing
(var cancel-counter 0)
(assert-error "ev/gather 4.1" (ev/gather
(defer (++ cancel-counter) (ev/take (ev/chan)))
(defer (++ cancel-counter) (ev/take (ev/chan)))
(error :oops)))
(assert (= cancel-counter 2) "ev/gather 4.2")
# Net testing
# 2904c19ed
(repeat 10
(defn handler
@@ -165,6 +208,7 @@
(:close s))
# Test on both server and client
# 504411e
(defn names-handler
[stream]
(defer (:close stream)
@@ -175,6 +219,7 @@
(assert (= port 8000) "localname port server")))
# Test localname and peername
# 077bf5eba
(repeat 10
(with [s (net/server "127.0.0.1" "8000" names-handler)]
(repeat 10
@@ -187,7 +232,7 @@
(gccollect))
# Create pipe
# 12f09ad2d
(var pipe-counter 0)
(def chan (ev/chan 10))
(let [[reader writer] (os/pipe)]
@@ -203,6 +248,7 @@
(ev/close writer)
(ev/take chan))
# cff52ded5
(var result nil)
(var fiber nil)
(set fiber
@@ -212,10 +258,11 @@
(ev/sleep 0)
(ev/cancel fiber "boop")
(assert (os/execute [janet "-e" `(+ 1 2 3)`] :xp) "os/execute self")
# f0dbc2e
(assert (os/execute [;run janet "-e" `(+ 1 2 3)`] :xp) "os/execute self")
# Test some channel
# e76b8da26
(def c1 (ev/chan))
(def c2 (ev/chan))
(def arr @[])
@@ -257,12 +304,45 @@
(assert (= (slice arr) (slice (range 100))) "ev/chan-close 3")
# threaded channels
# 868cdb9
(def ch (ev/thread-chan 2))
(def att (ev/thread-chan 109))
(assert att "`att` was nil after creation")
(ev/give ch att)
(ev/do-thread
(assert (ev/take ch) "channel packing bug for threaded abstracts on threaded channels."))
(assert (ev/take ch)
"channel packing bug for threaded abstracts on threaded channels."))
# marshal channels
# 76be8006a
(def ch (ev/chan 10))
(ev/give ch "hello")
(ev/give ch "world")
(def ch2 (-> ch marshal unmarshal))
(def item1 (ev/take ch2))
(def item2 (ev/take ch2))
(assert (= item1 "hello"))
(assert (= item2 "world"))
# ev/take, suspended, channel closed
(def ch (ev/chan))
(ev/go |(ev/chan-close ch))
(assert (= (ev/take ch) nil))
# ev/give, suspended, channel closed
(def ch (ev/chan))
(ev/go |(ev/chan-close ch))
(assert (= (ev/give ch 1) nil))
# ev/select, suspended take operation, channel closed
(def ch (ev/chan))
(ev/go |(ev/chan-close ch))
(assert (= (ev/select ch) [:close ch]))
# ev/select, suspended give operation, channel closed
(def ch (ev/chan))
(ev/go |(ev/chan-close ch))
(assert (= (ev/select [ch 1]) [:close ch]))
(end-suite)

View File

@@ -1,4 +1,4 @@
# Copyright (c) 2022 Calvin Rose & contributors
# Copyright (c) 2023 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
@@ -19,29 +19,30 @@
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite 12)
(var counter 0)
(def thunk (delay (++ counter)))
(assert (= (thunk) 1) "delay 1")
(assert (= counter 1) "delay 2")
(assert (= (thunk) 1) "delay 3")
(assert (= counter 1) "delay 4")
(start-suite)
# We should get ARM support...
(def has-ffi (dyn 'ffi/native))
(def has-full-ffi
(and has-ffi
(when-let [entry (dyn 'ffi/calling-conventions)]
(def fficc (entry :value))
(> (length (fficc)) 1)))) # all arches support :none
# FFI check
# d80356158
(compwhen has-ffi
(ffi/context))
(compwhen has-ffi
(ffi/defbind memcpy :ptr [dest :ptr src :ptr n :size]))
(compwhen has-ffi
(compwhen has-full-ffi
(def buffer1 @"aaaa")
(def buffer2 @"bbbb")
(memcpy buffer1 buffer2 4)
(assert (= (string buffer1) "bbbb") "ffi 1 - memcpy"))
# cfaae47ce
(compwhen has-ffi
(assert (= 8 (ffi/size [:int :char])) "size unpacked struct 1")
(assert (= 5 (ffi/size [:pack :int :char])) "size packed struct 1")
@@ -49,7 +50,8 @@
(assert (= 4 (ffi/align [:int :char])) "align 1")
(assert (= 1 (ffi/align [:pack :int :char])) "align 2")
(assert (= 1 (ffi/align [:int :char :pack-all])) "align 3")
(assert (= 26 (ffi/size [:char :pack :int @[:char 21]])) "array struct size"))
(assert (= 26 (ffi/size [:char :pack :int @[:char 21]]))
"array struct size"))
(end-suite)

258
test/suite-inttypes.janet Normal file
View File

@@ -0,0 +1,258 @@
# Copyright (c) 2023 Calvin Rose & contributors
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# some tests for bigint
# 319575c
(def i64 int/s64)
(def u64 int/u64)
(assert-no-error
"create some uint64 bigints"
(do
# from number
(def a (u64 10))
# max double we can convert to int (2^53)
(def b (u64 0x1fffffffffffff))
(def b (u64 (math/pow 2 53)))
# from string
(def c (u64 "0xffff_ffff_ffff_ffff"))
(def c (u64 "32rvv_vv_vv_vv"))
(def d (u64 "123456789"))))
# Conversion back to an int32
# 88db9751d
(assert (= (int/to-number (u64 0xFaFa)) 0xFaFa))
(assert (= (int/to-number (i64 0xFaFa)) 0xFaFa))
(assert (= (int/to-number (u64 9007199254740991)) 9007199254740991))
(assert (= (int/to-number (i64 9007199254740991)) 9007199254740991))
(assert (= (int/to-number (i64 -9007199254740991)) -9007199254740991))
(assert-error
"u64 out of bounds for safe integer"
(int/to-number (u64 "9007199254740993"))
(assert-error
"s64 out of bounds for safe integer"
(int/to-number (i64 "-9007199254740993"))))
(assert-error
"int/to-number fails on non-abstract types"
(int/to-number 1))
(assert-no-error
"create some int64 bigints"
(do
# from number
(def a (i64 -10))
# max double we can convert to int (2^53)
(def b (i64 0x1fffffffffffff))
(def b (i64 (math/pow 2 53)))
# from string
(def c (i64 "0x7fff_ffff_ffff_ffff"))
(def d (i64 "123456789"))))
(assert-error
"bad initializers"
(do
# double to big to be converted to uint64 without truncation (2^53 + 1)
(def b (u64 (+ 0xffff_ffff_ffff_ff 1)))
(def b (u64 (+ (math/pow 2 53) 1)))
# out of range 65 bits
(def c (u64 "0x1ffffffffffffffff"))
# just to big
(def d (u64 "123456789123456789123456789"))))
(assert (= (:/ (u64 "0xffff_ffff_ffff_ffff") 8 2) (u64 "0xfffffffffffffff"))
"bigint operations 1")
(assert (let [a (u64 0xff)] (= (:+ a a a a) (:* a 2 2)))
"bigint operations 2")
# 5ae520a2c
(assert (= (string (i64 -123)) "-123") "i64 prints reasonably")
(assert (= (string (u64 123)) "123") "u64 prints reasonably")
# 1db6d0e0b
(assert-error
"trap INT64_MIN / -1"
(:/ (int/s64 "-0x8000_0000_0000_0000") -1))
# int/s64 and int/u64 serialization
# 6aea7c7f7
(assert (deep= (int/to-bytes (u64 0)) @"\x00\x00\x00\x00\x00\x00\x00\x00"))
(assert (deep= (int/to-bytes (i64 1) :le)
@"\x01\x00\x00\x00\x00\x00\x00\x00"))
(assert (deep= (int/to-bytes (i64 1) :be)
@"\x00\x00\x00\x00\x00\x00\x00\x01"))
(assert (deep= (int/to-bytes (i64 -1))
@"\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF"))
(assert (deep= (int/to-bytes (i64 -5) :be)
@"\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFB"))
(assert (deep= (int/to-bytes (u64 1) :le)
@"\x01\x00\x00\x00\x00\x00\x00\x00"))
(assert (deep= (int/to-bytes (u64 1) :be)
@"\x00\x00\x00\x00\x00\x00\x00\x01"))
(assert (deep= (int/to-bytes (u64 300) :be)
@"\x00\x00\x00\x00\x00\x00\x01\x2C"))
# int/s64 int/u64 to existing buffer
# bbb3e16fd
(let [buf1 @""
buf2 @"abcd"]
(assert (deep= (int/to-bytes (i64 1) :le buf1)
@"\x01\x00\x00\x00\x00\x00\x00\x00"))
(assert (deep= buf1 @"\x01\x00\x00\x00\x00\x00\x00\x00"))
(assert (deep= (int/to-bytes (u64 300) :be buf2)
@"abcd\x00\x00\x00\x00\x00\x00\x01\x2C")))
# int/s64 and int/u64 paramater type checking
# 6aea7c7f7
(assert-error
"bad value passed to int/to-bytes"
(int/to-bytes 1))
# 6aea7c7f7
(assert-error
"invalid endianness passed to int/to-bytes"
(int/to-bytes (u64 0) :little))
# bbb3e16fd
(assert-error
"invalid buffer passed to int/to-bytes"
(int/to-bytes (u64 0) :little :buffer))
# Right hand operators
# 4fe005e3c
(assert (= (int/s64 (sum (range 10))) (sum (map int/s64 (range 10))))
"right hand operators 1")
(assert (= (int/s64
(product (range 1 10))) (product (map int/s64 (range 1 10))))
"right hand operators 2")
(assert (= (int/s64 15) (bor 10 (int/s64 5)) (bor (int/s64 10) 5))
"right hand operators 3")
# Integer type checks
# 11067d7a5
(assert (compare= 0 (- (int/u64 "1000") 1000)) "subtract from int/u64")
(assert (odd? (int/u64 "1001")) "odd? 1")
(assert (not (odd? (int/u64 "1000"))) "odd? 2")
(assert (odd? (int/s64 "1001")) "odd? 3")
(assert (not (odd? (int/s64 "1000"))) "odd? 4")
(assert (odd? (int/s64 "-1001")) "odd? 5")
(assert (not (odd? (int/s64 "-1000"))) "odd? 6")
(assert (even? (int/u64 "1000")) "even? 1")
(assert (not (even? (int/u64 "1001"))) "even? 2")
(assert (even? (int/s64 "1000")) "even? 3")
(assert (not (even? (int/s64 "1001"))) "even? 4")
(assert (even? (int/s64 "-1000")) "even? 5")
(assert (not (even? (int/s64 "-1001"))) "even? 6")
# integer type operations
(defn modcheck [x y]
(assert (= (string (mod x y)) (string (mod (int/s64 x) y)))
(string "int/s64 (mod " x " " y ") expected " (mod x y) ", got "
(mod (int/s64 x) y)))
(assert (= (string (% x y)) (string (% (int/s64 x) y)))
(string "int/s64 (% " x " " y ") expected " (% x y) ", got "
(% (int/s64 x) y))))
(modcheck 1 2)
(modcheck 1 3)
(modcheck 4 2)
(modcheck 4 1)
(modcheck 10 3)
(modcheck 10 -3)
(modcheck -10 3)
(modcheck -10 -3)
# Check for issue #1130
# 7e65c2bda
(var d (int/s64 7))
(mod 0 d)
(var d (int/s64 7))
(def result (seq [n :in (range -21 0)] (mod n d)))
(assert (deep= result
(map int/s64 @[0 1 2 3 4 5 6 0 1 2 3 4 5 6 0 1 2 3 4 5 6]))
"issue #1130")
# issue #272 - 81d301a42
(let [MAX_INT_64_STRING "9223372036854775807"
MAX_UINT_64_STRING "18446744073709551615"
MAX_INT_IN_DBL_STRING "9007199254740991"
NAN (math/log -1)
INF (/ 1 0)
MINUS_INF (/ -1 0)
compare-poly-tests
[[(int/s64 3) (int/u64 3) 0]
[(int/s64 -3) (int/u64 3) -1]
[(int/s64 3) (int/u64 2) 1]
[(int/s64 3) 3 0] [(int/s64 3) 4 -1] [(int/s64 3) -9 1]
[(int/u64 3) 3 0] [(int/u64 3) 4 -1] [(int/u64 3) -9 1]
[3 (int/s64 3) 0] [3 (int/s64 4) -1] [3 (int/s64 -5) 1]
[3 (int/u64 3) 0] [3 (int/u64 4) -1] [3 (int/u64 2) 1]
[(int/s64 MAX_INT_64_STRING) (int/u64 MAX_UINT_64_STRING) -1]
[(int/s64 MAX_INT_IN_DBL_STRING)
(scan-number MAX_INT_IN_DBL_STRING) 0]
[(int/u64 MAX_INT_IN_DBL_STRING)
(scan-number MAX_INT_IN_DBL_STRING) 0]
[(+ 1 (int/u64 MAX_INT_IN_DBL_STRING))
(scan-number MAX_INT_IN_DBL_STRING) 1]
[(int/s64 0) INF -1] [(int/u64 0) INF -1]
[MINUS_INF (int/u64 0) -1] [MINUS_INF (int/s64 0) -1]
[(int/s64 1) NAN 0] [NAN (int/u64 1) 0]]]
(each [x y c] compare-poly-tests
(assert (= c (compare x y))
(string/format "compare polymorphic %q %q %d" x y c))))
# marshal
(def m1 (u64 3141592654))
(def m2 (unmarshal (marshal m1)))
(assert (= m1 m2) "marshal/unmarshal")
# compare u64/u64
(assert (= (compare (u64 1) (u64 2)) -1) "compare 1")
(assert (= (compare (u64 1) (u64 1)) 0) "compare 2")
(assert (= (compare (u64 2) (u64 1)) +1) "compare 3")
# compare i64/i64
(assert (= (compare (i64 -1) (i64 +1)) -1) "compare 4")
(assert (= (compare (i64 +1) (i64 +1)) 0) "compare 5")
(assert (= (compare (i64 +1) (i64 -1)) +1) "compare 6")
# compare u64/i64
(assert (= (compare (u64 1) (i64 2)) -1) "compare 7")
(assert (= (compare (u64 1) (i64 -1)) +1) "compare 8")
(assert (= (compare (u64 -1) (i64 -1)) +1) "compare 9")
# compare i64/u64
(assert (= (compare (i64 1) (u64 2)) -1) "compare 10")
(assert (= (compare (i64 -1) (u64 1)) -1) "compare 11")
(assert (= (compare (i64 -1) (u64 -1)) -1) "compare 12")
(end-suite)

82
test/suite-io.janet Normal file
View File

@@ -0,0 +1,82 @@
# Copyright (c) 2023 Calvin Rose & contributors
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Printing to buffers
# d47804d22
(def out-buf @"")
(def err-buf @"")
(with-dyns [:out out-buf :err err-buf]
(print "Hello")
(prin "hi")
(eprint "Sup")
(eprin "not much."))
(assert (= (string out-buf) "Hello\nhi") "print and prin to buffer 1")
(assert (= (string err-buf) "Sup\nnot much.")
"eprint and eprin to buffer 1")
# Printing to functions
# 4e263b8c3
(def out-buf @"")
(defn prepend [x]
(with-dyns [:out out-buf]
(prin "> " x)))
(with-dyns [:out prepend]
(print "Hello world"))
(assert (= (string out-buf) "> Hello world\n")
"print to buffer via function")
# c2f844157, 3c523d66e
(with [f (file/temp)]
(assert (= 0 (file/tell f)) "start of file")
(file/write f "foo\n")
(assert (= 4 (file/tell f)) "after written string")
(file/flush f)
(file/seek f :set 0)
(assert (= 0 (file/tell f)) "start of file again")
(assert (= (string (file/read f :all)) "foo\n") "temp files work"))
# issue #1055 - 2c927ea76
(let [b @""]
(defn dummy [a b c]
(+ a b c))
(trace dummy)
(defn errout [arg]
(buffer/push b arg))
(assert (= 6 (with-dyns [*err* errout] (dummy 1 2 3)))
"trace to custom err function")
(assert (deep= @"trace (dummy 1 2 3)\n" b) "trace buffer correct"))
# xprintf
(def b @"")
(defn to-b [a] (buffer/push b a))
(xprintf to-b "123")
(assert (deep= b @"123\n") "xprintf to buffer")
(assert-error "cannot print to 3" (xprintf 3 "123"))
(end-suite)

142
test/suite-marsh.janet Normal file
View File

@@ -0,0 +1,142 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Marshal
# 98f2c6f
(def um-lookup (env-lookup (fiber/getenv (fiber/current))))
(def m-lookup (invert um-lookup))
# 0cf10946b
(defn testmarsh [x msg]
(def marshx (marshal x m-lookup))
(def out (marshal (unmarshal marshx um-lookup) m-lookup))
(assert (= (string marshx) (string out)) msg))
(testmarsh nil "marshal nil")
(testmarsh false "marshal false")
(testmarsh true "marshal true")
(testmarsh 1 "marshal small integers")
(testmarsh -1 "marshal integers (-1)")
(testmarsh 199 "marshal small integers (199)")
(testmarsh 5000 "marshal medium integers (5000)")
(testmarsh -5000 "marshal small integers (-5000)")
(testmarsh 10000 "marshal large integers (10000)")
(testmarsh -10000 "marshal large integers (-10000)")
(testmarsh 1.0 "marshal double")
(testmarsh "doctordolittle" "marshal string")
(testmarsh :chickenshwarma "marshal symbol")
(testmarsh @"oldmcdonald" "marshal buffer")
(testmarsh @[1 2 3 4 5] "marshal array")
(testmarsh [tuple 1 2 3 4 5] "marshal tuple")
(testmarsh @{1 2 3 4} "marshal table")
(testmarsh {1 2 3 4} "marshal struct")
(testmarsh (fn [x] x) "marshal function 0")
(testmarsh (fn name [x] x) "marshal function 1")
(testmarsh (fn [x] (+ 10 x 2)) "marshal function 2")
(testmarsh (fn thing [x] (+ 11 x x 30)) "marshal function 3")
(testmarsh map "marshal function 4")
(testmarsh reduce "marshal function 5")
(testmarsh (fiber/new (fn [] (yield 1) 2)) "marshal simple fiber 1")
(testmarsh (fiber/new (fn [&] (yield 1) 2)) "marshal simple fiber 2")
# issue #53 - 1147482e6
(def strct {:a @[nil]})
(put (strct :a) 0 strct)
(testmarsh strct "cyclic struct")
# More marshalling code
# issue #53 - 1147482e6
(defn check-image
"Run a marshaling test using the make-image and load-image functions."
[x msg]
(def im (make-image x))
# (printf "\nimage-hash: %d" (-> im string hash))
(assert-no-error msg (load-image im)))
(check-image (fn [] (fn [] 1)) "marshal nested functions")
(check-image (fiber/new (fn [] (fn [] 1)))
"marshal nested functions in fiber")
(check-image (fiber/new (fn [] (fiber/new (fn [] 1))))
"marshal nested fibers")
# issue #53 - f4908ebc4
(def issue-53-x
(fiber/new
(fn []
(var y (fiber/new (fn [] (print "1") (yield) (print "2")))))))
(check-image issue-53-x "issue 53 regression")
# Marshal closure over non resumable fiber
# issue #317 - 7c4ffe9b9
(do
(defn f1
[a]
(defn f1 [] (++ (a 0)))
(defn f2 [] (++ (a 0)))
(error [f1 f2]))
(def [_ tup] (protect (f1 @[0])))
(def [f1 f2] (unmarshal (marshal tup make-image-dict) load-image-dict))
(assert (= 1 (f1)) "marshal-non-resumable-closure 1")
(assert (= 2 (f2)) "marshal-non-resumable-closure 2"))
# Marshal closure over currently alive fiber
# issue #317 - 7c4ffe9b9
(do
(defn f1
[a]
(defn f1 [] (++ (a 0)))
(defn f2 [] (++ (a 0)))
(marshal [f1 f2] make-image-dict))
(def [f1 f2] (unmarshal (f1 @[0]) load-image-dict))
(assert (= 1 (f1)) "marshal-live-closure 1")
(assert (= 2 (f2)) "marshal-live-closure 2"))
(do
(var a 1)
(defn b [x] (+ a x))
(def c (unmarshal (marshal b)))
(assert (= 2 (c 1)) "marshal-on-stack-closure 1"))
# Issue #336 cases - don't segfault
# b145d4786
(assert-error "unmarshal errors 1" (unmarshal @"\xd6\xb9\xb9"))
(assert-error "unmarshal errors 2" (unmarshal @"\xd7bc"))
# 5bbd50785
(assert-error "unmarshal errors 3"
(unmarshal "\xd3\x01\xd9\x01\x62\xcf\x03\x78\x79\x7a"
load-image-dict))
# fcc610f53
(assert-error "unmarshal errors 4"
(unmarshal
@"\xD7\xCD\0e/p\x98\0\0\x03\x01\x01\x01\x02\0\0\x04\0\xCEe/p../tools
\0\0\0/afl\0\0\x01\0erate\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE
\xA8\xDE\xDE\xDE\xDE\xDE\xDE\0\0\0\xDE\xDE_unmarshal_testcase3.ja
neldb\0\0\0\xD8\x05printG\x01\0\xDE\xDE\xDE'\x03\0marshal_tes/\x02
\0\0\0\0\0*\xFE\x01\04\x02\0\0'\x03\0\r\0\r\0\r\0\r" load-image-dict))
# XXX: still needed? see 72beeeea
(gccollect)
(end-suite)

69
test/suite-math.janet Normal file
View File

@@ -0,0 +1,69 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# First commit removing the integer number type
# 6b95326d7
(assert (= 400 (math/sqrt 160000)) "sqrt(160000)=400")
# RNGs
# aee168721
(defn test-rng
[rng]
(assert (all identity (seq [i :range [0 1000]]
(<= (math/rng-int rng i) i))) "math/rng-int test")
(assert (all identity (seq [i :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
(test-rng (math/rng (:int seedrng))))
# 70328437f
(assert (deep-not= (-> 123 math/rng (:buffer 16))
(-> 456 math/rng (:buffer 16))) "math/rng-buffer 1")
(assert-no-error "math/rng-buffer 2" (math/seedrandom "abcdefg"))
# 027b2a8
(defn assert-many [f n e]
(var good true)
(loop [i :range [0 n]]
(if (not (f))
(set good false)))
(assert good e))
(assert-many (fn [] (>= 1 (math/random) 0)) 200 "(random) between 0 and 1")
# 06aa0a124
(assert (= (math/gcd 462 1071) 21) "math/gcd 1")
(assert (= (math/lcm 462 1071) 23562) "math/lcm 1")
# math gamma
# e6babd8
(assert (< 11899423.08 (math/gamma 11.5) 11899423.085) "math/gamma")
(assert (< 2605.1158 (math/log-gamma 500) 2605.1159) "math/log-gamma")
(end-suite)

151
test/suite-os.janet Normal file
View File

@@ -0,0 +1,151 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
(def janet (dyn :executable))
(def run (filter next (string/split " " (os/getenv "SUBRUN" ""))))
# OS Date test
# 719f7ba0c
(assert (deep= {:year-day 0
:minutes 30
:month 0
:dst false
:seconds 0
:year 2014
:month-day 0
:hours 20
:week-day 3}
(os/date 1388608200)) "os/date")
# OS mktime test
# 3ee43c3ab
(assert (= 1388608200 (os/mktime {:year-day 0
:minutes 30
:month 0
:dst false
:seconds 0
:year 2014
:month-day 0
:hours 20
:week-day 3})) "os/mktime")
(def now (os/time))
(assert (= (os/mktime (os/date now)) now) "UTC os/mktime")
(assert (= (os/mktime (os/date now true) true) now) "local os/mktime")
(assert (= (os/mktime {:year 1970}) 0) "os/mktime default values")
# OS strftime test
# 5cd729c4c
(assert (= (os/strftime "%Y-%m-%d %H:%M:%S" 0) "1970-01-01 00:00:00")
"strftime UTC epoch")
(assert (= (os/strftime "%Y-%m-%d %H:%M:%S" 1388608200)
"2014-01-01 20:30:00")
"strftime january 2014")
(assert (= (try (os/strftime "%%%d%t") ([err] err))
"invalid conversion specifier '%t'")
"invalid conversion specifier")
# 07db4c530
(os/setenv "TESTENV1" "v1")
(os/setenv "TESTENV2" "v2")
(assert (= (os/getenv "TESTENV1") "v1") "getenv works")
(def environ (os/environ))
(assert (= [(environ "TESTENV1") (environ "TESTENV2")] ["v1" "v2"])
"environ works")
# Ensure randomness puts n of pred into our buffer eventually
# 0ac5b243c
(defn cryptorand-check
[n pred]
(def max-attempts 10000)
(var attempts 0)
(while (not= attempts max-attempts)
(def cryptobuf (os/cryptorand 10))
(when (= n (count pred cryptobuf))
(break))
(++ attempts))
(not= attempts max-attempts))
(def v (math/rng-int (math/rng (os/time)) 100))
(assert (cryptorand-check 0 |(= $ v)) "cryptorand skips value sometimes")
(assert (cryptorand-check 1 |(= $ v)) "cryptorand has value sometimes")
(do
(def buf (buffer/new-filled 1))
(os/cryptorand 1 buf)
(assert (= (in buf 0) 0) "cryptorand doesn't overwrite buffer")
(assert (= (length buf) 2) "cryptorand appends to buffer"))
# 80db68210
(assert-no-error "realtime clock" (os/clock :realtime))
(assert-no-error "cputime clock" (os/clock :cputime))
(assert-no-error "monotonic clock" (os/clock :monotonic))
(def before (os/clock :monotonic))
(def after (os/clock :monotonic))
(assert (>= after before) "monotonic clock is monotonic")
# Perm strings
# a0d61e45d
(assert (= (os/perm-int "rwxrwxrwx") 8r777) "perm 1")
(assert (= (os/perm-int "rwxr-xr-x") 8r755) "perm 2")
(assert (= (os/perm-int "rw-r--r--") 8r644) "perm 3")
(assert (= (band (os/perm-int "rwxrwxrwx") 8r077) 8r077) "perm 4")
(assert (= (band (os/perm-int "rwxr-xr-x") 8r077) 8r055) "perm 5")
(assert (= (band (os/perm-int "rw-r--r--") 8r077) 8r044) "perm 6")
(assert (= (os/perm-string 8r777) "rwxrwxrwx") "perm 7")
(assert (= (os/perm-string 8r755) "rwxr-xr-x") "perm 8")
(assert (= (os/perm-string 8r644) "rw-r--r--") "perm 9")
# os/execute with environment variables
# issue #636 - 7e2c433ab
(assert (= 0 (os/execute [;run janet "-e" "(+ 1 2 3)"] :pe
(merge (os/environ) {"HELLO" "WORLD"})))
"os/execute with env")
# os/execute regressions
# 427f7c362
(for i 0 10
(assert (= i (os/execute [;run janet "-e"
(string/format "(os/exit %d)" i)] :p))
(string "os/execute " i)))
# os/execute IO redirection
(assert-no-error "IO redirection"
(defn devnull []
(def os (os/which))
(def path (if (or (= os :mingw) (= os :windows))
"NUL"
"/dev/null"))
(os/open path :w))
(with [dn (devnull)]
(os/execute [;run janet
"-e"
"(print :foo) (eprint :bar)"]
:px
{:out dn :err dn})))
(end-suite)

192
test/suite-parse.janet Normal file
View File

@@ -0,0 +1,192 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# 7e46ead2f
(assert (not false) "false literal")
(assert true "true literal")
(assert (not nil) "nil literal")
(assert (= '(1 2 3) (quote (1 2 3)) (tuple 1 2 3)) "quote shorthand")
# String literals
# 45f8db0
(assert (= "abcd" "\x61\x62\x63\x64") "hex escapes")
(assert (= "\e" "\x1B") "escape character")
(assert (= "\x09" "\t") "tab character")
# Long strings
# 7e6342720
(assert (= "hello, world" `hello, world`) "simple long string")
(assert (= "hello, \"world\"" `hello, "world"`)
"long string with embedded quotes")
(assert (= "hello, \\\\\\ \"world\"" `hello, \\\ "world"`)
"long string with embedded quotes and backslashes")
#
# Longstring indentation
#
# 7aa4241
(defn reindent
"Reindent the contents of a longstring as the Janet parser would.
This include removing leading and trailing newlines."
[text indent]
# Detect minimum indent
(var rewrite true)
(each index (string/find-all "\n" text)
(for i (+ index 1) (+ index indent 1)
(case (get text i)
nil (break)
(chr "\n") (break)
(chr " ") nil
(set rewrite false))))
# Only re-indent if no dedented characters.
(def str
(if rewrite
(peg/replace-all ~(* "\n" (between 0 ,indent " ")) "\n" text)
text))
(def first-nl (= (chr "\n") (first str)))
(def last-nl (= (chr "\n") (last str)))
(string/slice str (if first-nl 1 0) (if last-nl -2)))
(defn reindent-reference
"Same as reindent but use parser functionality. Useful for
validating conformance."
[text indent]
(if (empty? text) (break text))
(def source-code
(string (string/repeat " " indent) "``````"
text
"``````"))
(parse source-code))
(var indent-counter 0)
(defn check-indent
[text indent]
(++ indent-counter)
(let [a (reindent text indent)
b (reindent-reference text indent)]
(assert (= a b)
(string "indent " indent-counter " (indent=" indent ")"))))
(check-indent "" 0)
(check-indent "\n" 0)
(check-indent "\n" 1)
(check-indent "\n\n" 0)
(check-indent "\n\n" 1)
(check-indent "\nHello, world!" 0)
(check-indent "\nHello, world!" 1)
(check-indent "Hello, world!" 0)
(check-indent "Hello, world!" 1)
(check-indent "\n Hello, world!" 4)
(check-indent "\n Hello, world!\n" 4)
(check-indent "\n Hello, world!\n " 4)
(check-indent "\n Hello, world!\n " 4)
(check-indent "\n Hello, world!\n dedented text\n " 4)
(check-indent "\n Hello, world!\n indented text\n " 4)
# Symbols with @ character
# d68eae9
(def @ 1)
(assert (= @ 1) "@ symbol")
(def @-- 2)
(assert (= @-- 2) "@-- symbol")
(def @hey 3)
(assert (= @hey 3) "@hey symbol")
# Parser clone
# 43520ac67
(def p (parser/new))
(assert (= 7 (parser/consume p "(1 2 3 ")) "parser 1")
(def p2 (parser/clone p))
(parser/consume p2 ") 1 ")
(parser/consume p ") 1 ")
(assert (deep= (parser/status p) (parser/status p2)) "parser 2")
(assert (deep= (parser/state p) (parser/state p2)) "parser 3")
# Parser errors
# 976dfc719
(defn parse-error [input]
(def p (parser/new))
(parser/consume p input)
(parser/error p))
# Invalid utf-8 sequences
(assert (not= nil (parse-error @"\xc3\x28")) "reject invalid utf-8 symbol")
(assert (not= nil (parse-error @":\xc3\x28")) "reject invalid utf-8 keyword")
# Parser line and column numbers
# 77b79e989
(defn parser-location [input &opt location]
(def p (parser/new))
(parser/consume p input)
(if location
(parser/where p ;location)
(parser/where p)))
(assert (= [1 7] (parser-location @"(+ 1 2)")) "parser location 1")
(assert (= [5 7] (parser-location @"(+ 1 2)" [5])) "parser location 2")
(assert (= [10 10] (parser-location @"(+ 1 2)" [10 10])) "parser location 3")
# Issue #861 - should be valgrind clean
# 39c6be7cb
(def step1 "(a b c d)\n")
(def step2 "(a b)\n")
(def p1 (parser/new))
(parser/state p1)
(parser/consume p1 step1)
(loop [v :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)
# parser delimiter errors
(defn test-error [delim fmt]
(def p (parser/new))
(parser/consume p delim)
(parser/eof p)
(def msg (string/format fmt delim))
(assert (= (parser/error p) msg) "delimiter error"))
(each c [ "(" "{" "[" "\"" "``" ]
(test-error c "unexpected end of source, %s opened at line 1, column 1"))
# parser/insert
(def p (parser/new))
(parser/consume p "(")
(parser/insert p "hello")
(parser/consume p ")")
(assert (= (parser/produce p) ["hello"]))
(def p (parser/new))
(parser/consume p `("hel`)
(parser/insert p `lo`)
(parser/consume p `")`)
(assert (= (parser/produce p) ["hello"]))
(end-suite)

664
test/suite-peg.janet Normal file
View File

@@ -0,0 +1,664 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Peg
# 83f4a11bf
(defn check-match
[pat text should-match]
(def result (peg/match pat text))
(assert (= (not should-match) (not result))
(string "check-match " text)))
# 798c88b4c
(defn check-deep
[pat text what]
(def result (peg/match pat text))
(assert (deep= result what) (string "check-deep " text)))
# Just numbers
# 83f4a11bf
(check-match '(* 4 -1) "abcd" true)
(check-match '(* 4 -1) "abc" false)
(check-match '(* 4 -1) "abcde" false)
# Simple pattern
# 83f4a11bf
(check-match '(* (some (range "az" "AZ")) -1) "hello" true)
(check-match '(* (some (range "az" "AZ")) -1) "hello world" false)
(check-match '(* (some (range "az" "AZ")) -1) "1he11o" false)
(check-match '(* (some (range "az" "AZ")) -1) "" false)
# Pre compile
# ff0d3a008
(def pegleg (peg/compile '{:item "abc" :main (* :item "," :item -1)}))
(peg/match pegleg "abc,abc")
# Bad Grammars
# 192705113
(assert-error "peg/compile error 1" (peg/compile nil))
(assert-error "peg/compile error 2" (peg/compile @{}))
(assert-error "peg/compile error 3" (peg/compile '{:a "abc" :b "def"}))
(assert-error "peg/compile error 4" (peg/compile '(blarg "abc")))
(assert-error "peg/compile error 5" (peg/compile '(1 2 3)))
# IP address
# 40845b5c1
(def ip-address
'{:d (range "09")
:0-4 (range "04")
:0-5 (range "05")
:byte (+
(* "25" :0-5)
(* "2" :0-4 :d)
(* "1" :d :d)
(between 1 2 :d))
:main (* :byte "." :byte "." :byte "." :byte)})
(check-match ip-address "10.240.250.250" true)
(check-match ip-address "0.0.0.0" true)
(check-match ip-address "1.2.3.4" true)
(check-match ip-address "256.2.3.4" false)
(check-match ip-address "256.2.3.2514" false)
# Substitution test with peg
# d7626f8c5
(def grammar '(accumulate (any (+ (/ "dog" "purple panda") (<- 1)))))
(defn try-grammar [text]
(assert (= (string/replace-all "dog" "purple panda" text)
(0 (peg/match grammar text))) text))
(try-grammar "i have a dog called doug the dog. he is good.")
(try-grammar "i have a dog called doug the dog. he is a good boy.")
(try-grammar "i have a dog called doug the do")
(try-grammar "i have a dog called doug the dog")
(try-grammar "i have a dog called doug the dogg")
(try-grammar "i have a dog called doug the doggg")
(try-grammar "i have a dog called doug the dogggg")
# Peg CSV test
# 798c88b4c
(def csv
'{:field (+
(* `"` (% (any (+ (<- (if-not `"` 1))
(* (constant `"`) `""`)))) `"`)
(<- (any (if-not (set ",\n") 1))))
:main (* :field (any (* "," :field)) (+ "\n" -1))})
(defn check-csv
[str res]
(check-deep csv str res))
(check-csv "1,2,3" @["1" "2" "3"])
(check-csv "1,\"2\",3" @["1" "2" "3"])
(check-csv ``1,"1""",3`` @["1" "1\"" "3"])
# Nested Captures
# 798c88b4c
(def grmr '(capture (* (capture "a") (capture 1) (capture "c"))))
(check-deep grmr "abc" @["a" "b" "c" "abc"])
(check-deep grmr "acc" @["a" "c" "c" "acc"])
# Functions in grammar
# 798c88b4c
(def grmr-triple ~(% (any (/ (<- 1) ,(fn [x] (string x x x))))))
(check-deep grmr-triple "abc" @["aaabbbccc"])
(check-deep grmr-triple "" @[""])
(check-deep grmr-triple " " @[" "])
(def counter ~(/ (group (any (<- 1))) ,length))
(check-deep counter "abcdefg" @[7])
# Capture Backtracking
# ff0d3a008
(check-deep '(+ (* (capture "c") "d") "ce") "ce" @[])
# Matchtime capture
# 192705113
(def scanner (peg/compile ~(cmt (capture (some 1)) ,scan-number)))
(check-deep scanner "123" @[123])
(check-deep scanner "0x86" @[0x86])
(check-deep scanner "-1.3e-7" @[-1.3e-7])
(check-deep scanner "123A" nil)
# Recursive grammars
# 170e785b7
(def g '{:main (+ (* "a" :main "b") "c")})
(check-match g "c" true)
(check-match g "acb" true)
(check-match g "aacbb" true)
(check-match g "aadbb" false)
# Back reference
# d0ec89c7c
(def wrapped-string
~{:pad (any "=")
:open (* "[" (<- :pad :n) "[")
:close (* "]" (cmt (* (-> :n) (<- :pad)) ,=) "]")
:main (* :open (any (if-not :close 1)) :close -1)})
(check-match wrapped-string "[[]]" true)
(check-match wrapped-string "[==[a]==]" true)
(check-match wrapped-string "[==[]===]" false)
(check-match wrapped-string "[[blark]]" true)
(check-match wrapped-string "[[bl[ark]]" true)
(check-match wrapped-string "[[bl]rk]]" true)
(check-match wrapped-string "[[bl]rk]] " false)
(check-match wrapped-string "[=[bl]]rk]=] " false)
(check-match wrapped-string "[=[bl]==]rk]=] " false)
(check-match wrapped-string "[===[]==]===]" true)
(def janet-longstring
~{:delim (some "`")
:open (capture :delim :n)
:close (cmt (* (not (> -1 "`")) (-> :n) (<- (backmatch :n))) ,=)
:main (* :open (any (if-not :close 1)) :close -1)})
(check-match janet-longstring "`john" false)
(check-match janet-longstring "abc" false)
(check-match janet-longstring "` `" true)
(check-match janet-longstring "` `" true)
(check-match janet-longstring "`` ``" true)
(check-match janet-longstring "``` `` ```" true)
(check-match janet-longstring "`` ```" false)
(check-match janet-longstring "`a``b`" false)
# Line and column capture
# 776ce586b
(def line-col (peg/compile '(any (* (line) (column) 1))))
(check-deep line-col "abcd" @[1 1 1 2 1 3 1 4])
(check-deep line-col "" @[])
(check-deep line-col "abcd\n" @[1 1 1 2 1 3 1 4 1 5])
(check-deep line-col "abcd\nz" @[1 1 1 2 1 3 1 4 1 5 2 1])
# Backmatch
# 711fe64a5
(def backmatcher-1 '(* (capture (any "x") :1) "y" (backmatch :1) -1))
(check-match backmatcher-1 "y" true)
(check-match backmatcher-1 "xyx" true)
(check-match backmatcher-1 "xxxxxxxyxxxxxxx" true)
(check-match backmatcher-1 "xyxx" false)
(check-match backmatcher-1 (string (string/repeat "x" 73) "y") false)
(check-match backmatcher-1 (string (string/repeat "x" 10000) "y") false)
(check-match backmatcher-1 (string (string/repeat "x" 10000) "y"
(string/repeat "x" 10000)) true)
(def backmatcher-2 '(* '(any "x") "y" (backmatch) -1))
(check-match backmatcher-2 "y" true)
(check-match backmatcher-2 "xyx" true)
(check-match backmatcher-2 "xxxxxxxyxxxxxxx" true)
(check-match backmatcher-2 "xyxx" false)
(check-match backmatcher-2 (string (string/repeat "x" 73) "y") false)
(check-match backmatcher-2 (string (string/repeat "x" 10000) "y") false)
(check-match backmatcher-2 (string (string/repeat "x" 10000) "y"
(string/repeat "x" 10000)) true)
(def longstring-2 '(* '(some "`")
(some (if-not (backmatch) 1))
(backmatch) -1))
(check-match longstring-2 "`john" false)
(check-match longstring-2 "abc" false)
(check-match longstring-2 "` `" true)
(check-match longstring-2 "` `" true)
(check-match longstring-2 "`` ``" true)
(check-match longstring-2 "``` `` ```" true)
(check-match longstring-2 "`` ```" false)
# Optional
# 4eeadd746
(check-match '(* (opt "hi") -1) "" true)
(check-match '(* (opt "hi") -1) "hi" true)
(check-match '(* (opt "hi") -1) "no" false)
(check-match '(* (? "hi") -1) "" true)
(check-match '(* (? "hi") -1) "hi" true)
(check-match '(* (? "hi") -1) "no" false)
# Drop
# b4934cedd
(check-deep '(drop '"hello") "hello" @[])
(check-deep '(drop "hello") "hello" @[])
# Add bytecode verification for peg unmarshaling
# e88a9af2f
# This should be valgrind clean.
(var pegi 3)
(defn marshpeg [p]
(assert (-> p peg/compile marshal unmarshal)
(string "peg marshal " (++ pegi))))
(marshpeg '(* 1 2 (set "abcd") "asdasd" (+ "." 3)))
(marshpeg '(% (* (+ 1 2 3) (* "drop" "bear") '"hi")))
(marshpeg '(> 123 "abcd"))
(marshpeg '{:main (* 1 "hello" :main)})
(marshpeg '(range "AZ"))
(marshpeg '(if-not "abcdf" 123))
(marshpeg '(error ($)))
(marshpeg '(* "abcd" (constant :hi)))
(marshpeg ~(/ "abc" ,identity))
(marshpeg '(if-not "abcdf" 123))
(marshpeg ~(cmt "abcdf" ,identity))
(marshpeg '(group "abc"))
# Peg swallowing errors
# 159651117
(assert (try (peg/match ~(/ '1 ,(fn [x] (nil x))) "x") ([err] err))
"errors should not be swallowed")
(assert (try ((fn [x] (nil x))) ([err] err))
"errors should not be swallowed 2")
# Check for bad memoization (+ :a) should mean different things in
# different contexts
# 8bc8709d0
(def redef-a
~{:a "abc"
:c (+ :a)
:main (* :c {:a "def" :main (+ :a)} -1)})
(check-match redef-a "abcdef" true)
(check-match redef-a "abcabc" false)
(check-match redef-a "defdef" false)
# 54a04b589
(def redef-b
~{:pork {:pork "beef" :main (+ -1 (* 1 :pork))}
:main :pork})
(check-match redef-b "abeef" true)
(check-match redef-b "aabeef" false)
(check-match redef-b "aaaaaa" false)
# Integer parsing
# 45feb5548
(check-deep '(int 1) "a" @[(chr "a")])
(check-deep '(uint 1) "a" @[(chr "a")])
(check-deep '(int-be 1) "a" @[(chr "a")])
(check-deep '(uint-be 1) "a" @[(chr "a")])
(check-deep '(int 1) "\xFF" @[-1])
(check-deep '(uint 1) "\xFF" @[255])
(check-deep '(int-be 1) "\xFF" @[-1])
(check-deep '(uint-be 1) "\xFF" @[255])
(check-deep '(int 2) "\xFF\x7f" @[0x7fff])
(check-deep '(int-be 2) "\x7f\xff" @[0x7fff])
(check-deep '(uint 2) "\xff\x7f" @[0x7fff])
(check-deep '(uint-be 2) "\x7f\xff" @[0x7fff])
(check-deep '(uint-be 2) "\x7f\xff" @[0x7fff])
(check-deep '(uint 8) "\xff\x7f\x00\x00\x00\x00\x00\x00"
@[(int/u64 0x7fff)])
(check-deep '(int 8) "\xff\x7f\x00\x00\x00\x00\x00\x00"
@[(int/s64 0x7fff)])
(check-deep '(uint 7) "\xff\x7f\x00\x00\x00\x00\x00" @[(int/u64 0x7fff)])
(check-deep '(int 7) "\xff\x7f\x00\x00\x00\x00\x00" @[(int/s64 0x7fff)])
(check-deep '(* (int 2) -1) "123" nil)
# to/thru bug
# issue #640 - 742469a8b
(check-deep '(to -1) "aaaa" @[])
(check-deep '(thru -1) "aaaa" @[])
(check-deep ''(to -1) "aaaa" @["aaaa"])
(check-deep ''(thru -1) "aaaa" @["aaaa"])
(check-deep '(to "b") "aaaa" nil)
(check-deep '(thru "b") "aaaa" nil)
# unref
# 96513665d
(def grammar
(peg/compile
~{:main (* :tagged -1)
:tagged (unref (replace (* :open-tag :value :close-tag) ,struct))
:open-tag (* (constant :tag) "<" (capture :w+ :tag-name) ">")
:value (* (constant :value) (group (any (+ :tagged :untagged))))
:close-tag (* "</" (backmatch :tag-name) ">")
:untagged (capture (any (if-not "<" 1)))}))
(check-deep grammar "<p><em>foobar</em></p>"
@[{:tag "p" :value @[{:tag "em" :value @["foobar"]}]}])
(check-deep grammar "<p>foobar</p>" @[{:tag "p" :value @["foobar"]}])
# Using a large test grammar
# cf05ff610
(def- specials {'fn true
'var true
'do true
'while true
'def true
'splice true
'set true
'unquote true
'quasiquote true
'quote true
'if true})
(defn- check-number [text] (and (scan-number text) text))
(defn capture-sym
[text]
(def sym (symbol text))
[(if (or (root-env sym) (specials sym)) :coresym :symbol) text])
(def grammar
~{:ws (set " \v\t\r\f\n\0")
:readermac (set "';~,")
:symchars (+ (range "09" "AZ" "az" "\x80\xFF")
(set "!$%&*+-./:<?=>@^_|"))
:token (some :symchars)
:hex (range "09" "af" "AF")
:escape (* "\\" (+ (set "ntrvzf0e\"\\")
(* "x" :hex :hex)
(error (constant "bad hex escape"))))
:comment (/ '(* "#" (any (if-not (+ "\n" -1) 1))) (constant :comment))
:symbol (/ ':token ,capture-sym)
:keyword (/ '(* ":" (any :symchars)) (constant :keyword))
:constant (/ '(+ "true" "false" "nil") (constant :constant))
:bytes (* "\"" (any (+ :escape (if-not "\"" 1))) "\"")
:string (/ ':bytes (constant :string))
:buffer (/ '(* "@" :bytes) (constant :string))
:long-bytes {:delim (some "`")
:open (capture :delim :n)
:close (cmt (* (not (> -1 "`")) (-> :n) '(backmatch :n))
,=)
:main (drop (* :open (any (if-not :close 1)) :close))}
:long-string (/ ':long-bytes (constant :string))
:long-buffer (/ '(* "@" :long-bytes) (constant :string))
:number (/ (cmt ':token ,check-number) (constant :number))
:raw-value (+ :comment :constant :number :keyword
:string :buffer :long-string :long-buffer
:parray :barray :ptuple :btuple :struct :dict :symbol)
:value (* (? '(some (+ :ws :readermac))) :raw-value '(any :ws))
:root (any :value)
:root2 (any (* :value :value))
:ptuple (* '"(" :root (+ '")" (error "")))
:btuple (* '"[" :root (+ '"]" (error "")))
:struct (* '"{" :root2 (+ '"}" (error "")))
:parray (* '"@" :ptuple)
:barray (* '"@" :btuple)
:dict (* '"@" :struct)
:main (+ :root (error ""))})
(def p (peg/compile grammar))
# Just make sure is valgrind clean.
(def p (-> p make-image load-image))
(assert (peg/match p "abc") "complex peg grammar 1")
(assert (peg/match p "[1 2 3 4]") "complex peg grammar 2")
###
### Compiling brainfuck to Janet.
###
# 20d5d560f
(def- bf-peg
"Peg for compiling brainfuck into a Janet source ast."
(peg/compile
~{:+ (/ '(some "+") ,(fn [x] ~(+= (DATA POS) ,(length x))))
:- (/ '(some "-") ,(fn [x] ~(-= (DATA POS) ,(length x))))
:> (/ '(some ">") ,(fn [x] ~(+= POS ,(length x))))
:< (/ '(some "<") ,(fn [x] ~(-= POS ,(length x))))
:. (* "." (constant (prinf "%c" (get DATA POS))))
:loop (/ (* "[" :main "]") ,(fn [& captures]
~(while (not= (get DATA POS) 0)
,;captures)))
:main (any (+ :s :loop :+ :- :> :< :.))}))
(defn bf
"Run brainfuck."
[text]
(eval
~(let [DATA (array/new-filled 100 0)]
(var POS 50)
,;(peg/match bf-peg text))))
(defn test-bf
"Test some bf for expected output."
[input output]
(def b @"")
(with-dyns [:out b]
(bf input))
(assert (= (string output) (string b))
(string "bf input '"
input
"' failed, expected "
(describe output)
", got "
(describe (string b))
".")))
(test-bf (string "++++++++[>++++[>++>+++>+++>+<<<<-]>+>+>->>+[<]<-]"
">>.>---.+++++++..+++.>>.<-.<.+++.------.--------"
".>>+.>++.") "Hello World!\n")
(test-bf (string ">++++++++"
"[-<+++++++++>]<.>>+>-[+]++>++>+++[>[->+++<<+++>]<<]"
">-----.>->+++..+++.>-.<<+[>[+>+]>>]<--------------"
".>>.+++.------.--------.>+.>+.")
"Hello World!\n")
(test-bf (string "+[+[<<<+>>>>]+<-<-<<<+<++]<<.<++.<++..+++.<<++.<---"
".>>.>.+++.------.>-.>>--.")
"Hello, World!")
# Regression test
# issue #300 - 714bd61d5
# Just don't segfault
(assert (peg/match '{:main (replace "S" {"S" :spade})} "S7")
"regression #300")
# Lenprefix rule
# 8b5bcaee3
(def peg (peg/compile ~(* (lenprefix (/ (* '(any (if-not ":" 1)) ":")
,scan-number) 1) -1)))
(assert (peg/match peg "5:abcde") "lenprefix 1")
(assert (not (peg/match peg "5:abcdef")) "lenprefix 2")
(assert (not (peg/match peg "5:abcd")) "lenprefix 3")
# Packet capture
# 8b5bcaee3
(def peg2
(peg/compile
~{# capture packet length in tag :header-len
:packet-header (* (/ ':d+ ,scan-number :header-len) ":")
# capture n bytes from a backref :header-len
:packet-body '(lenprefix (-> :header-len) 1)
# header, followed by body, and drop the :header-len capture
:packet (/ (* :packet-header :packet-body) ,|$1)
# any exact seqence of packets (no extra characters)
:main (* (any :packet) -1)}))
(assert (deep= @["a" "bb" "ccc"] (peg/match peg2 "1:a2:bb3:ccc"))
"lenprefix 4")
(assert (deep= @["a" "bb" "cccccc"] (peg/match peg2 "1:a2:bb6:cccccc"))
"lenprefix 5")
(assert (= nil (peg/match peg2 "1:a2:bb:5:cccccc")) "lenprefix 6")
(assert (= nil (peg/match peg2 "1:a2:bb:7:cccccc")) "lenprefix 7")
# Issue #412
# 677737d34
(assert (peg/match '(* "a" (> -1 "a") "b") "abc")
"lookhead does not move cursor")
# 6d096551f
(def peg3
~{:main (* "(" (thru ")"))})
(def peg4 (peg/compile ~(* (thru "(") '(to ")"))))
(assert (peg/match peg3 "(12345)") "peg thru 1")
(assert (not (peg/match peg3 " (12345)")) "peg thru 2")
(assert (not (peg/match peg3 "(12345")) "peg thru 3")
(assert (= "abc" (0 (peg/match peg4 "123(abc)"))) "peg thru/to 1")
(assert (= "abc" (0 (peg/match peg4 "(abc)"))) "peg thru/to 2")
(assert (not (peg/match peg4 "123(abc")) "peg thru/to 3")
# 86e12369b
(def peg5 (peg/compile [3 "abc"]))
(assert (:match peg5 "abcabcabc") "repeat alias 1")
(assert (:match peg5 "abcabcabcac") "repeat alias 2")
(assert (not (:match peg5 "abcabc")) "repeat alias 3")
# Peg find and find-all
# c26f57362
(def p "/usr/local/bin/janet")
(assert (= (peg/find '"n/" p) 13) "peg find 1")
(assert (not (peg/find '"t/" p)) "peg find 2")
(assert (deep= (peg/find-all '"/" p) @[0 4 10 14]) "peg find-all")
# Peg replace and replace-all
# e548e1f6e
(defn check-replacer
[x y z]
(assert (= (string/replace x y z) (string (peg/replace x y z)))
"replacer test replace")
(assert (= (string/replace-all x y z) (string (peg/replace-all x y z)))
"replacer test replace-all"))
(check-replacer "abc" "Z" "abcabcabcabasciabsabc")
(check-replacer "abc" "Z" "")
(check-replacer "aba" "ZZZZZZ" "ababababababa")
(check-replacer "aba" "" "ababababababa")
# 485099fd6
(check-replacer "aba" string/ascii-upper "ababababababa")
(check-replacer "aba" 123 "ababababababa")
(assert (= (string (peg/replace-all ~(set "ab") string/ascii-upper "abcaa"))
"ABcAA")
"peg/replace-all cfunction")
(assert (= (string (peg/replace-all ~(set "ab") |$ "abcaa"))
"abcaa")
"peg/replace-all function")
# 9dc7e8ed3
(defn peg-test [name f peg subst text expected]
(assert (= (string (f peg subst text)) expected) name))
(peg-test "peg/replace has access to captures"
peg/replace
~(sequence "." (capture (set "ab")))
(fn [str char] (string/format "%s -> %s, " str (string/ascii-upper char)))
".a.b.c"
".a -> A, .b.c")
(peg-test "peg/replace-all has access to captures"
peg/replace-all
~(sequence "." (capture (set "ab")))
(fn [str char] (string/format "%s -> %s, " str (string/ascii-upper char)))
".a.b.c"
".a -> A, .b -> B, .c")
# Peg bug
# eab5f67c5
(assert (deep= @[] (peg/match '(any 1) @"")) "peg empty pattern 1")
(assert (deep= @[] (peg/match '(any 1) (buffer))) "peg empty pattern 2")
(assert (deep= @[] (peg/match '(any 1) "")) "peg empty pattern 3")
(assert (deep= @[] (peg/match '(any 1) (string))) "peg empty pattern 4")
(assert (deep= @[] (peg/match '(* "test" (any 1)) @"test"))
"peg empty pattern 5")
(assert (deep= @[] (peg/match '(* "test" (any 1)) (buffer "test")))
"peg empty pattern 6")
# number pattern
# cccbdc164
(assert (deep= @[111] (peg/match '(number :d+) "111"))
"simple number capture 1")
(assert (deep= @[255] (peg/match '(number :w+) "0xff"))
"simple number capture 2")
# Marshal and unmarshal pegs
# 446ab037b
(def p (-> "abcd" peg/compile marshal unmarshal))
(assert (peg/match p "abcd") "peg marshal 1")
(assert (peg/match p "abcdefg") "peg marshal 2")
(assert (not (peg/match p "zabcdefg")) "peg marshal 3")
# to/thru bug
# issue #971 - a895219d2
(def pattern
(peg/compile
'{:dd (sequence :d :d)
:sep (set "/-")
:date (sequence :dd :sep :dd)
:wsep (some (set " \t"))
:entry (group (sequence (capture :date) :wsep (capture :date)))
:main (some (thru :entry))}))
(def alt-pattern
(peg/compile
'{:dd (sequence :d :d)
:sep (set "/-")
:date (sequence :dd :sep :dd)
:wsep (some (set " \t"))
:entry (group (sequence (capture :date) :wsep (capture :date)))
:main (some (choice :entry 1))}))
(def text "1800-10-818-9-818 16/12\n17/12 19/12\n20/12 11/01")
(assert (deep= (peg/match pattern text) (peg/match alt-pattern text))
"to/thru bug #971")
# 14657a7
(def- sym-prefix-peg
(peg/compile
~{:symchar (+ (range "\x80\xff" "AZ" "az" "09")
(set "!$%&*+-./:<?=>@^_"))
:anchor (drop (cmt ($) ,|(= $ 0)))
:cap (* (+ (> -1 (not :symchar)) :anchor) (* ($) '(some :symchar)))
:recur (+ :cap (> -1 :recur))
:main (> -1 :recur)}))
(assert (deep= (peg/match sym-prefix-peg @"123" 3) @[0 "123"])
"peg lookback")
(assert (deep= (peg/match sym-prefix-peg @"1234" 4) @[0 "1234"])
"peg lookback 2")
# issue #1027 - 356b39c6f
(assert (deep= (peg/replace-all '(* (<- 1) 1 (backmatch))
"xxx" "aba cdc efa")
@"xxx xxx efa")
"peg replace-all 1")
# issue #1026 - 9341081a4
(assert (deep=
(peg/match '(not (* (constant 7) "a")) "hello")
@[]) "peg not")
(assert (deep=
(peg/match '(if-not (* (constant 7) "a") "hello") "hello")
@[]) "peg if-not")
(assert (deep=
(peg/match '(if-not (drop (* (constant 7) "a")) "hello") "hello")
@[]) "peg if-not drop")
(assert (deep=
(peg/match '(if (not (* (constant 7) "a")) "hello") "hello")
@[]) "peg if not")
(end-suite)

65
test/suite-pp.janet Normal file
View File

@@ -0,0 +1,65 @@
# Copyright (c) 2023 Calvin Rose & contributors
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Appending buffer to self
# 6b76ac3d1
(with-dyns [:out @""]
(prin "abcd")
(prin (dyn :out))
(prin (dyn :out))
(assert (deep= (dyn :out) @"abcdabcdabcdabcd") "print buffer to self"))
# Buffer self blitting, check for use after free
# bbcfaf128
(def buf1 @"1234567890")
(buffer/blit buf1 buf1 -1)
(buffer/blit buf1 buf1 -1)
(buffer/blit buf1 buf1 -1)
(buffer/blit buf1 buf1 -1)
(assert (= (string buf1) (string/repeat "1234567890" 16))
"buffer blit against self")
# Check for bugs with printing self with buffer/format
# bbcfaf128
(def buftemp @"abcd")
(assert (= (string (buffer/format buftemp "---%p---" buftemp))
`abcd---@"abcd"---`) "buffer/format on self 1")
(def buftemp @"abcd")
(assert (= (string (buffer/format buftemp "---%p %p---" buftemp buftemp))
`abcd---@"abcd" @"abcd"---`) "buffer/format on self 2")
# 5c364e0
(defn check-jdn [x]
(assert (deep= (parse (string/format "%j" x)) x) "round trip jdn"))
(check-jdn 0)
(check-jdn nil)
(check-jdn [])
(check-jdn @[[] [] 1231 9.123123 -123123 0.1231231230001])
(check-jdn -0.123123123123)
(check-jdn 12837192371923)
(check-jdn "a string")
(check-jdn @"a buffer")
(end-suite)

202
test/suite-specials.janet Normal file
View File

@@ -0,0 +1,202 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Regression Test #137
# affcb5b45
(def [a b c] (range 10))
(assert (= a 0) "regression #137 (1)")
(assert (= b 1) "regression #137 (2)")
(assert (= c 2) "regression #137 (3)")
(var [x y z] (range 10))
(assert (= x 0) "regression #137 (4)")
(assert (= y 1) "regression #137 (5)")
(assert (= z 2) "regression #137 (6)")
# Test destructuring
# 23dcfb986
(do
(def test-tab @{:a 1 :b 2})
(def {:a a :b b} test-tab)
(assert (= a 1) "dictionary destructuring 1")
(assert (= b 2) "dictionary destructuring 2"))
(do
(def test-tab @{'a 1 'b 2 3 4})
(def {'a a 'b b (+ 1 2) c} test-tab)
(assert (= a 1) "dictionary destructuring 3")
(assert (= b 2) "dictionary destructuring 4")
(assert (= c 4) "dictionary destructuring 5 - expression as key"))
# cb5af974a
(let [test-tuple [:a :b 1 2]]
(def [a b one two] test-tuple)
(assert (= a :a) "tuple destructuring 1")
(assert (= b :b) "tuple destructuring 2")
(assert (= two 2) "tuple destructuring 3"))
(let [test-tuple [:a :b 1 2]]
(def [a & rest] test-tuple)
(assert (= a :a) "tuple destructuring 4 - rest")
(assert (= rest [:b 1 2]) "tuple destructuring 5 - rest"))
(do
(def [a b & rest] [:a :b nil :d])
(assert (= a :a) "tuple destructuring 6 - rest")
(assert (= b :b) "tuple destructuring 7 - rest")
(assert (= rest [nil :d]) "tuple destructuring 8 - rest"))
# 71cffc973
(do
(def [[a b] x & rest] [[1 2] :a :c :b :a])
(assert (= a 1) "tuple destructuring 9 - rest")
(assert (= b 2) "tuple destructuring 10 - rest")
(assert (= x :a) "tuple destructuring 11 - rest")
(assert (= rest [:c :b :a]) "tuple destructuring 12 - rest"))
# 651e12cfe
(do
(def [a b & rest] [:a :b])
(assert (= a :a) "tuple destructuring 13 - rest")
(assert (= b :b) "tuple destructuring 14 - rest")
(assert (= rest []) "tuple destructuring 15 - rest"))
(do
(def [[a b & r1] c & r2] [[:a :b 1 2] :c 3 4])
(assert (= a :a) "tuple destructuring 16 - rest")
(assert (= b :b) "tuple destructuring 17 - rest")
(assert (= c :c) "tuple destructuring 18 - rest")
(assert (= r1 [1 2]) "tuple destructuring 19 - rest")
(assert (= r2 [3 4]) "tuple destructuring 20 - rest"))
# Metadata
# ec2d7bf34
(def foo-with-tags :a-tag :bar)
(assert (get (dyn 'foo-with-tags) :a-tag)
"extra keywords in def are metadata tags")
(def foo-with-meta {:baz :quux} :bar)
(assert (= :quux (get (dyn 'foo-with-meta) :baz))
"extra struct in def is metadata")
(defn foo-fn-with-meta {:baz :quux}
"This is a function"
[x]
(identity x))
(assert (= :quux (get (dyn 'foo-fn-with-meta) :baz))
"extra struct in defn is metadata")
(assert (= "(foo-fn-with-meta x)\n\nThis is a function"
(get (dyn 'foo-fn-with-meta) :doc))
"extra string in defn is docstring")
# Break
# 4a111b38b
(var summation 0)
(for i 0 10
(+= summation i)
(if (= i 7) (break)))
(assert (= summation 28) "break 1")
(assert (= nil ((fn [] (break) 4))) "break 2")
# Break with value
# 8ba112116
# Shouldn't error out
(assert-no-error "break 3" (for i 0 10 (if (> i 8) (break i))))
(assert-no-error "break 4" ((fn [i] (if (> i 8) (break i))) 100))
# No useless splices
# 7d57f8700
(check-compile-error '((splice [1 2 3]) 0))
(check-compile-error '(if ;[1 2] 5))
(check-compile-error '(while ;[1 2 3] (print :hi)))
(check-compile-error '(def x ;[1 2 3]))
(check-compile-error '(fn [x] ;[x 1 2 3]))
# No splice propagation
(check-compile-error '(+ 1 (do ;[2 3 4]) 5))
(check-compile-error '(+ 1 (upscope ;[2 3 4]) 5))
# compiler inlines when condition is constant, ensure that optimization
# doesn't break
(check-compile-error '(+ 1 (if true ;[3 4])))
(check-compile-error '(+ 1 (if false nil ;[3 4])))
# Keyword arguments
# 3f137ed0b
(defn myfn [x y z &keys {:a a :b b :c c}]
(+ x y z a b c))
(assert (= (+ ;(range 6)) (myfn 0 1 2 :a 3 :b 4 :c 5)) "keyword args 1")
(assert (= (+ ;(range 6)) (myfn 0 1 2 :a 1 :b 6 :c 5 :d 11))
"keyword args 2")
# Named arguments
# 87fc339
(defn named-arguments
[&named bob sally joe]
(+ bob sally joe))
(assert (= 15 (named-arguments :bob 3 :sally 5 :joe 7)) "named arguments 1")
# a117252
(defn named-opt-arguments
[&opt x &named a b c]
(+ x a b c))
(assert (= 10 (named-opt-arguments 1 :a 2 :b 3 :c 4)) "named arguments 2")
#
# fn compilation special
#
# b8032ec61
(defn myfn1 [[x y z] & more]
more)
(defn myfn2 [head & more]
more)
(assert (= (myfn1 [1 2 3] 4 5 6) (myfn2 [:a :b :c] 4 5 6))
"destructuring and varargs")
# Nested quasiquotation
# 4199c42fe
(def nested ~(a ~(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
(assert (deep= nested '(a ~(b ,(+ 1 2) ,(foo 4 d) e) f))
"nested quasiquote")
# Regression #400
# 7a84fc474
(assert (= nil (while (and false false)
(fn [])
(error "should not happen"))) "strangeloop 1")
(assert (= nil (while (not= nil nil)
(fn [])
(error "should not happen"))) "strangeloop 2")
# 919
# a097537a0
(defn test
[]
(var x 1)
(set x ~(,x ()))
x)
(assert (= (test) '(1 ())) "issue #919")
(end-suite)

View File

@@ -1,4 +1,4 @@
# Copyright (c) 2021 Calvin Rose
# Copyright (c) 2023 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
@@ -19,48 +19,20 @@
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite 2)
(start-suite)
# Buffer stuff
(defn buffer=
[a b]
(= (string a) (string b)))
# 8a346ec
(assert (= (string/join @["one" "two" "three"]) "onetwothree")
"string/join 1 argument")
(assert (= (string/join @["one" "two" "three"] ", ") "one, two, three")
"string/join 2 arguments")
(assert (= (string/join @[] ", ") "") "string/join empty array")
(assert (buffer= @"abcd" @"abcd") "buffer equal 1")
(assert (buffer= @"abcd" (buffer "ab" "cd")) "buffer equal 2")
(assert (not= @"" @"") "buffer not equal 1")
(assert (not= @"abcd" @"abcd") "buffer not equal 2")
(defn buffer-factory
[]
@"im am a buffer")
(assert (not= (buffer-factory) (buffer-factory)) "buffer instantiation")
(assert (= (length @"abcdef") 6) "buffer length")
# Looping idea
(def xs
(seq [x :in '[-1 0 1] y :in '[-1 0 1] :when (not= x y 0)] (tuple x y)))
(def txs (apply tuple xs))
(assert (= txs '[[-1 -1] [-1 0] [-1 1] [0 -1] [0 1] [1 -1] [1 0] [1 1]]) "nested seq")
# Generators
(def gen (generate [x :range [0 100] :when (pos? (% x 4))] x))
(var gencount 0)
(loop [x :in gen]
(++ gencount)
(assert (pos? (% x 4)) "generate in loop"))
(assert (= gencount 75) "generate loop count")
# Check x:digits: works as symbol and not a hex number
(def x1 100)
(assert (= x1 100) "x1 as symbol")
(def X1 100)
(assert (= X1 100) "X1 as symbol")
(assert (= (string/find "123" "abc123def") 3) "string/find positive")
(assert (= (string/find "1234" "abc123def") nil) "string/find negative")
# String functions
# f41dab8f6
(assert (= 3 (string/find "abc" " abcdefghijklmnop")) "string/find 1")
(assert (= 0 (string/find "A" "A")) "string/find 2")
(assert (string/has-prefix? "" "foo") "string/has-prefix? 1")
@@ -69,48 +41,100 @@
(assert (string/has-suffix? "" "foo") "string/has-suffix? 1")
(assert (string/has-suffix? "oo" "foo") "string/has-suffix? 2")
(assert (not (string/has-suffix? "f" "foo")) "string/has-suffix? 3")
(assert (= (string/replace "X" "." "XXX...XXX...XXX") ".XX...XXX...XXX") "string/replace 1")
(assert (= (string/replace-all "X" "." "XXX...XXX...XXX") "...............") "string/replace-all 1")
(assert (= (string/replace-all "XX" "." "XXX...XXX...XXX") ".X....X....X") "string/replace-all 2")
(assert (= (string/ascii-lower "ABCabc&^%!@:;.") "abcabc&^%!@:;.") "string/ascii-lower")
(assert (= (string/ascii-upper "ABCabc&^%!@:;.") "ABCABC&^%!@:;.") "string/ascii-lower")
(assert (= (string/replace "X" "." "XXX...XXX...XXX") ".XX...XXX...XXX")
"string/replace 1")
(assert (= (string/replace-all "X" "." "XXX...XXX...XXX") "...............")
"string/replace-all 1")
(assert (= (string/replace-all "XX" "." "XXX...XXX...XXX") ".X....X....X")
"string/replace-all 2")
(assert (= (string/replace "xx" string/ascii-upper "xxyxyxyxxxy")
"XXyxyxyxxxy") "string/replace function")
(assert (= (string/replace-all "xx" string/ascii-upper "xxyxyxyxxxy")
"XXyxyxyXXxy") "string/replace-all function")
(assert (= (string/replace "x" 12 "xyx") "12yx")
"string/replace stringable")
(assert (= (string/replace-all "x" 12 "xyx") "12y12")
"string/replace-all stringable")
(assert (= (string/ascii-lower "ABCabc&^%!@:;.") "abcabc&^%!@:;.")
"string/ascii-lower")
(assert (= (string/ascii-upper "ABCabc&^%!@:;.") "ABCABC&^%!@:;.")
"string/ascii-lower")
(assert (= (string/reverse "") "") "string/reverse 1")
(assert (= (string/reverse "a") "a") "string/reverse 2")
(assert (= (string/reverse "abc") "cba") "string/reverse 3")
(assert (= (string/reverse "abcd") "dcba") "string/reverse 4")
(assert (= (string/join @["one" "two" "three"] ",") "one,two,three") "string/join 1")
(assert (= (string/join @["one" "two" "three"] ", ") "one, two, three") "string/join 2")
(assert (= (string/join @["one" "two" "three"]) "onetwothree") "string/join 3")
(assert (= (string/join @["one" "two" "three"] ",") "one,two,three")
"string/join 1")
(assert (= (string/join @["one" "two" "three"] ", ") "one, two, three")
"string/join 2")
(assert (= (string/join @["one" "two" "three"]) "onetwothree")
"string/join 3")
(assert (= (string/join @[] "hi") "") "string/join 4")
(assert (= (string/trim " abcd ") "abcd") "string/trim 1")
(assert (= (string/trim "abcd \t\t\r\f") "abcd") "string/trim 2")
(assert (= (string/trim "\n\n\t abcd") "abcd") "string/trim 3")
(assert (= (string/trim "") "") "string/trim 4")
(assert (= (string/triml " abcd ") "abcd ") "string/triml 1")
(assert (= (string/triml "\tabcd \t\t\r\f") "abcd \t\t\r\f") "string/triml 2")
(assert (= (string/triml "\tabcd \t\t\r\f") "abcd \t\t\r\f")
"string/triml 2")
(assert (= (string/triml "abcd ") "abcd ") "string/triml 3")
(assert (= (string/trimr " abcd ") " abcd") "string/trimr 1")
(assert (= (string/trimr "\tabcd \t\t\r\f") "\tabcd") "string/trimr 2")
(assert (= (string/trimr " abcd") " abcd") "string/trimr 3")
(assert (deep= (string/split "," "one,two,three") @["one" "two" "three"]) "string/split 1")
(assert (deep= (string/split "," "onetwothree") @["onetwothree"]) "string/split 2")
(assert (deep= (string/find-all "e" "onetwothree") @[2 9 10]) "string/find-all 1")
(assert (deep= (string/find-all "," "onetwothree") @[]) "string/find-all 2")
(assert (deep= (string/split "," "one,two,three") @["one" "two" "three"])
"string/split 1")
(assert (deep= (string/split "," "onetwothree") @["onetwothree"])
"string/split 2")
(assert (deep= (string/find-all "e" "onetwothree") @[2 9 10])
"string/find-all 1")
(assert (deep= (string/find-all "," "onetwothree") @[])
"string/find-all 2")
# b26a7bb22
(assert-error "string/find error 1" (string/find "" "abcd"))
(assert-error "string/split error 1" (string/split "" "abcd"))
(assert-error "string/replace error 1" (string/replace "" "." "abcd"))
(assert-error "string/replace-all error 1" (string/replace-all "" "." "abcdabcd"))
(assert-error "string/replace-all error 1"
(string/replace-all "" "." "abcdabcd"))
(assert-error "string/find-all error 1" (string/find-all "" "abcd"))
# Check if abstract test works
(assert (abstract? stdout) "abstract? stdout")
(assert (abstract? stdin) "abstract? stdin")
(assert (abstract? stderr) "abstract? stderr")
(assert (not (abstract? nil)) "not abstract? nil")
(assert (not (abstract? 1)) "not abstract? 1")
(assert (not (abstract? 3)) "not abstract? 3")
(assert (not (abstract? 5)) "not abstract? 5")
# String bugs
# bcba0c027
(assert (deep= (string/find-all "qq" "qqq") @[0 1]) "string/find-all 1")
(assert (deep= (string/find-all "q" "qqq") @[0 1 2]) "string/find-all 2")
(assert (deep= (string/split "qq" "1qqqqz") @["1" "" "z"]) "string/split 1")
(assert (deep= (string/split "aa" "aaa") @["" "a"]) "string/split 2")
# some tests for string/format
# 0f0c415
(assert (= (string/format "pi = %6.3f" math/pi) "pi = 3.142") "%6.3f")
(assert (= (string/format "pi = %+6.3f" math/pi) "pi = +3.142") "%6.3f")
(assert (= (string/format "pi = %40.20g" math/pi)
"pi = 3.141592653589793116") "%6.3f")
(assert (= (string/format "🐼 = %6.3f" math/pi) "🐼 = 3.142") "UTF-8")
(assert (= (string/format "π = %.8g" math/pi) "π = 3.1415927") "π")
(assert (= (string/format "\xCF\x80 = %.8g" math/pi) "\xCF\x80 = 3.1415927")
"\xCF\x80")
# String check-set
# b4e25e559
(assert (string/check-set "abc" "a") "string/check-set 1")
(assert (not (string/check-set "abc" "z")) "string/check-set 2")
(assert (string/check-set "abc" "abc") "string/check-set 3")
(assert (string/check-set "abc" "") "string/check-set 4")
(assert (not (string/check-set "" "aabc")) "string/check-set 5")
(assert (not (string/check-set "abc" "abcdefg")) "string/check-set 6")
# Trim empty string
# issue #174 - 9b605b27b
(assert (= "" (string/trim " ")) "string/trim regression")
# Keyword and Symbol slice
# e9911fee4
(assert (= :keyword (keyword/slice "some_keyword_slice" 5 12))
"keyword slice")
(assert (= 'symbol (symbol/slice "some_symbol_slice" 5 11)) "symbol slice")
(end-suite)

44
test/suite-strtod.janet Normal file
View File

@@ -0,0 +1,44 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Scan number
# 798c88b4c
(assert (= 1 (scan-number "1")) "scan-number 1")
(assert (= -1 (scan-number "-1")) "scan-number -1")
(assert (= 1.3e4 (scan-number "1.3e4")) "scan-number 1.3e4")
# Issue #183 - just parse it :)
# 688d297a1
1e-4000000000000000000000
# For undefined behavior sanitizer
# c876e63
0xf&1fffFFFF
# off by 1 error in inttypes
# a3e812b86
(assert (= (int/s64 "-0x8000_0000_0000_0000")
(+ (int/s64 "0x7FFF_FFFF_FFFF_FFFF") 1)) "int types wrap around")
(end-suite)

94
test/suite-struct.janet Normal file
View File

@@ -0,0 +1,94 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# 21bd960
(assert (= (struct 1 2 3 4 5 6 7 8) (struct 7 8 5 6 3 4 1 2))
"struct order does not matter 1")
# 42a88de
(assert (= (struct
:apple 1
6 :bork
'(1 2 3) 5)
(struct
6 :bork
'(1 2 3) 5
:apple 1)) "struct order does not matter 2")
# Denormal structs
# 38a7e4faf
(assert (= (length {1 2 nil 3}) 1) "nil key struct literal")
(assert (= (length (struct 1 2 nil 3)) 1) "nil key struct ctor")
(assert (= (length (struct (/ 0 0) 2 1 3)) 1) "nan key struct ctor")
(assert (= (length {1 2 (/ 0 0) 3}) 1) "nan key struct literal")
(assert (= (length (struct 2 1 3 nil)) 1) "nil value struct ctor")
(assert (= (length {1 2 3 nil}) 1) "nil value struct literal")
# Struct duplicate elements
# 8bc2987a7
(assert (= {:a 3 :b 2} {:a 1 :b 2 :a 3}) "struct literal duplicate keys")
(assert (= {:a 3 :b 2} (struct :a 1 :b 2 :a 3))
"struct constructor duplicate keys")
# Struct prototypes
# 4d983e5
(def x (struct/with-proto {1 2 3 4} 5 6))
(def y (-> x marshal unmarshal))
(def z {1 2 3 4})
(assert (= 2 (get x 1)) "struct get proto value 1")
(assert (= 4 (get x 3)) "struct get proto value 2")
(assert (= 6 (get x 5)) "struct get proto value 3")
(assert (= x y) "struct proto marshal equality 1")
(assert (= (getproto x) (getproto y)) "struct proto marshal equality 2")
(assert (= 0 (cmp x y)) "struct proto comparison 1")
(assert (= 0 (cmp (getproto x) (getproto y))) "struct proto comparison 2")
(assert (not= (cmp x z) 0) "struct proto comparison 3")
(assert (not= (cmp y z) 0) "struct proto comparison 4")
(assert (not= x z) "struct proto comparison 5")
(assert (not= y z) "struct proto comparison 6")
(assert (= (x 5) 6) "struct proto get 1")
(assert (= (y 5) 6) "struct proto get 1")
(assert (deep= x y) "struct proto deep= 1")
(assert (deep-not= x z) "struct proto deep= 2")
(assert (deep-not= y z) "struct proto deep= 3")
# Check missing struct proto bug
# 868ec1a7e, e08394c8
(assert (struct/getproto (struct/with-proto {:a 1} :b 2 :c nil))
"missing struct proto")
# struct/with-proto
(assert-error "expected odd number of arguments" (struct/with-proto {} :a))
# struct/to-table
(def s (struct/with-proto {:a 1 :b 2} :name "john" ))
(def t1 (struct/to-table s true))
(def t2 (struct/to-table s false))
(assert (deep= t1 @{:name "john"}) "struct/to-table 1")
(assert (deep= t2 @{:name "john"}) "struct/to-table 2")
(assert (deep= (getproto t1) @{:a 1 :b 2}) "struct/to-table 3")
(assert (deep= (getproto t2) nil) "struct/to-table 4")
(end-suite)

42
test/suite-symcache.janet Normal file
View File

@@ -0,0 +1,42 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Symbol function
# 5460ff1
(assert (= (symbol "abc" 1 2 3) 'abc123) "symbol function")
# Gensym tests
# 3ccd68843
(assert (not= (gensym) (gensym)) "two gensyms not equal")
((fn []
(def syms (table))
(var counter 0)
(while (< counter 128)
(put syms (gensym) true)
(set counter (+ 1 counter)))
(assert (= (length syms) 128) "many symbols")))
# issue #753 - a78cbd91d
(assert (pos? (length (gensym))) "gensym not empty, regression #753")
(end-suite)

72
test/suite-table.janet Normal file
View File

@@ -0,0 +1,72 @@
# Copyright (c) 2023 Calvin Rose
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
(import ./helper :prefix "" :exit true)
(start-suite)
# Denormal tables
# 38a7e4faf
(assert (= (length @{1 2 nil 3}) 1) "nil key table literal")
(assert (= (length (table 1 2 nil 3)) 1) "nil key table ctor")
(assert (= (length (table (/ 0 0) 2 1 3)) 1) "nan key table ctor")
(assert (= (length @{1 2 (/ 0 0) 3}) 1) "nan key table literal")
(assert (= (length (table 2 1 3 nil)) 1) "nil value table ctor")
(assert (= (length @{1 2 3 nil}) 1) "nil value table literal")
# Table duplicate elements
(assert (deep= @{:a 3 :b 2} @{:a 1 :b 2 :a 3}) "table literal duplicate keys")
(assert (deep= @{:a 3 :b 2} (table :a 1 :b 2 :a 3))
"table constructor duplicate keys")
## Table prototypes
# 027b2a81c
(def roottab @{
:parentprop 123
})
(def childtab @{
:childprop 456
})
(table/setproto childtab roottab)
(assert (= 123 (get roottab :parentprop)) "table get 1")
(assert (= 123 (get childtab :parentprop)) "table get proto")
(assert (= nil (get roottab :childprop)) "table get 2")
(assert (= 456 (get childtab :childprop)) "proto no effect")
# b3aed1356
(assert-error
"table rawget regression"
(table/new -1))
# table/clone
# 392813667
(defn check-table-clone [x msg]
(assert (= (table/to-struct x) (table/to-struct (table/clone x))) msg))
(check-table-clone @{:a 123 :b 34 :c :hello : 945 0 1 2 3 4 5}
"table/clone 1")
(check-table-clone @{} "table/clone 2")
(end-suite)

Some files were not shown because too many files have changed in this diff Show More