diff --git a/.builds/openbsd.yml b/.builds/openbsd.yml index c55cd119..a83bdea2 100644 --- a/.builds/openbsd.yml +++ b/.builds/openbsd.yml @@ -13,7 +13,7 @@ tasks: gmake test-install - meson_min: | cd janet - meson setup build_meson_min --buildtype=release -Dsingle_threaded=true -Dnanbox=false -Ddynamic_modules=false -Ddocstrings=false -Dnet=false -Dsourcemaps=false -Dpeg=false -Dassembler=false -Dint_types=false -Dtyped_array=false -Dreduced_os=true + meson setup build_meson_min --buildtype=release -Dsingle_threaded=true -Dnanbox=false -Ddynamic_modules=false -Ddocstrings=false -Dnet=false -Dsourcemaps=false -Dpeg=false -Dassembler=false -Dint_types=false -Dtyped_array=false -Dreduced_os=true -Dffi=false cd build_meson_min ninja - meson_prf: | diff --git a/.gitattributes b/.gitattributes index 067fcc21..4ad85d26 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1,3 +1,4 @@ +*.janet linguist-language=Janet *.janet text eol=lf *.c text eol=lf *.h text eol=lf diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index 0f9991c0..e5c557dc 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -5,9 +5,14 @@ on: tags: - "v*.*.*" +permissions: + contents: read + jobs: release: + permissions: + contents: write # for softprops/action-gh-release to create GitHub release name: Build release binaries runs-on: ${{ matrix.os }} strategy: @@ -35,6 +40,8 @@ jobs: build/c/shell.c release-windows: + permissions: + contents: write # for softprops/action-gh-release to create GitHub release name: Build release binaries for windows runs-on: windows-latest steps: diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 71819468..63c90f7c 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -2,6 +2,9 @@ name: Test on: [push, pull_request] +permissions: + contents: read + jobs: test-posix: diff --git a/CHANGELOG.md b/CHANGELOG.md index e50db78d..f3e3caa8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,29 @@ # Changelog All notable changes to this project will be documented in this file. +## 1.23.1 - ??? +- Improve default error message from `assert`. +- Add the `tabseq` macro for simpler table comprehensions. +- Allow setting `(dyn :task-id)` in fibers to improve context in supervisor messages. Prior to + this change, supverisor messages over threaded channels would be from ambiguous threads/fibers. + +## 1.23.0 - 2022-06-20 +- Add experimental `ffi/` module for interfacing with dynamic libraries and raw function pointers. Only available + on 64 bit linux, mac, and bsd systems. +- Allow using `&named` in function prototypes for named arguments. This is a more ergonomic + variant of `&keys` that isn't as redundant, more self documenting, and allows extension to + things like default arguments. +- Add `delay` macro for lazy evaluate-and-save thunks. +- Remove pthread.h from janet.h for easier includes. +- Add `debugger` - an easy to use debugger function that just takes a fiber. +- `dofile` will now start a debugger on errors if the environment it is passed has `:debug` set. +- Add `debugger-on-status` function, which can be passed to `run-context` to start a debugger on + abnormal fiber signals. +- Allow running scripts with the `-d` flag to use the built-in debugger on errors and breakpoints. +- Add mutexes (locks) and reader-writer locks to ev module for thread coordination. +- Add `parse-all` as a generalization of the `parse` function. +- Add `os/cpu-count` to get the number of available processors on a machine + ## 1.22.0 - 2022-05-09 - Prohibit negative size argument to `table/new`. - Add `module/value`. diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index c65c99d5..23470084 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -43,7 +43,7 @@ For changes to the VM and Core code, you will probably need to know C. Janet is a subset of C99 that works with Microsoft Visual C++. This means most of C99 but with the following omissions. -* No `restrict` +* No `restrict` * Certain functions in the standard library are not always available In practice, this means programming for both MSVC on one hand and everything else on the other. @@ -64,6 +64,23 @@ ensure a consistent code style for C. All janet code in the project should be formatted similar to the code in core.janet. The auto formatting from janet.vim will work well. +## Typo Fixing and One-Line changes + +Typo fixes are welcome, as are simple one line fixes. Do not open many separate pull requests for each +individual typo fix. This is incredibly annoying to deal with as someone needs to review each PR, run +CI, and merge. Instead, accumulate batches of typo fixes into a single PR. If there are objections to +specific changes, these can be addressed in the review process before the final merge, if the changes +are accepted. + +Similarly, low effort and bad faith changes are annoying to developers and such issues may be closed +immediately without response. + +## Contributions from Automated Tools + +People making changes found or generated by automated tools MUST note this when opening an issue +or creating a pull request. This can help give context to developers if the change/issue is +confusing or nonsensical. + ## Suggesting Changes To suggest changes, open an issue on GitHub. Check GitHub for other issues diff --git a/Makefile b/Makefile index f8c4cfbb..fb3ecda1 100644 --- a/Makefile +++ b/Makefile @@ -108,6 +108,7 @@ JANET_CORE_SOURCES=src/core/abstract.c \ src/core/debug.c \ src/core/emit.c \ src/core/ev.c \ + src/core/ffi.c \ src/core/fiber.c \ src/core/gc.c \ src/core/inttypes.c \ @@ -167,9 +168,9 @@ build/c/janet.c: build/janet_boot src/boot/boot.janet ######################## ifeq ($(UNAME), Darwin) -SONAME=libjanet.1.22.dylib +SONAME=libjanet.1.23.dylib else -SONAME=libjanet.so.1.22 +SONAME=libjanet.so.1.23 endif build/c/shell.c: src/mainclient/shell.c @@ -282,7 +283,7 @@ install: $(JANET_TARGET) $(JANET_LIBRARY) $(JANET_STATIC_LIBRARY) build/janet.pc cp $(JANET_TARGET) '$(DESTDIR)$(BINDIR)/janet' mkdir -p '$(DESTDIR)$(INCLUDEDIR)/janet' cp -r build/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet' - ln -sf '$(DESTDIR)$(INCLUDEDIR)/janet/janet.h' '$(DESTDIR)$(INCLUDEDIR)/janet.h' + ln -sf -T ./janet/janet.h '$(DESTDIR)$(INCLUDEDIR)/janet.h' mkdir -p '$(DESTDIR)$(JANET_PATH)' mkdir -p '$(DESTDIR)$(LIBDIR)' if test $(UNAME) = Darwin ; then \ diff --git a/README.md b/README.md index 9c8d5f8d..30e8c009 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ [![Join the chat](https://badges.gitter.im/janet-language/community.svg)](https://gitter.im/janet-language/community)   -[![builds.sr.ht status](https://builds.sr.ht/~bakpakin/janet/commits/freebsd.yml.svg)](https://builds.sr.ht/~bakpakin/janet/commits/freebsd.yml?) -[![builds.sr.ht status](https://builds.sr.ht/~bakpakin/janet/commits/openbsd.yml.svg)](https://builds.sr.ht/~bakpakin/janet/commits/openbsd.yml?) +[![builds.sr.ht status](https://builds.sr.ht/~bakpakin/janet/commits/master/freebsd.yml.svg)](https://builds.sr.ht/~bakpakin/janet/commits/master/freebsd.yml?) +[![builds.sr.ht status](https://builds.sr.ht/~bakpakin/janet/commits/master/openbsd.yml.svg)](https://builds.sr.ht/~bakpakin/janet/commits/master/openbsd.yml?) [![Actions Status](https://github.com/janet-lang/janet/actions/workflows/test.yml/badge.svg)](https://github.com/janet-lang/janet/actions/workflows/test.yml) Janet logo @@ -89,6 +89,8 @@ cd somewhere/my/projects/janet make make test make repl +make install +make install-jpm-git ``` Find out more about the available make targets by running `make help`. @@ -103,6 +105,8 @@ cd somewhere/my/projects/janet make CC=gcc-x86 make test make repl +make install +make install-jpm-git ``` ### FreeBSD @@ -116,6 +120,8 @@ cd somewhere/my/projects/janet gmake gmake test gmake repl +gmake install +gmake install-jpm-git ``` ### NetBSD diff --git a/examples/evlocks.janet b/examples/evlocks.janet new file mode 100644 index 00000000..08b497f7 --- /dev/null +++ b/examples/evlocks.janet @@ -0,0 +1,45 @@ +(defn sleep + "Sleep the entire thread, not just a single fiber." + [n] + (os/sleep (* 0.1 n))) + +(defn work [lock n] + (ev/acquire-lock lock) + (print "working " n "...") + (sleep n) + (print "done working...") + (ev/release-lock lock)) + +(defn reader + [rwlock n] + (ev/acquire-rlock rwlock) + (print "reading " n "...") + (sleep n) + (print "done reading " n "...") + (ev/release-rlock rwlock)) + +(defn writer + [rwlock n] + (ev/acquire-wlock rwlock) + (print "writing " n "...") + (sleep n) + (print "done writing...") + (ev/release-wlock rwlock)) + +(defn test-lock + [] + (def lock (ev/lock)) + (for i 3 7 + (ev/spawn-thread + (work lock i)))) + +(defn test-rwlock + [] + (def rwlock (ev/rwlock)) + (for i 0 20 + (if (> 0.1 (math/random)) + (ev/spawn-thread (writer rwlock i)) + (ev/spawn-thread (reader rwlock i))))) + +(test-rwlock) +(test-lock) diff --git a/examples/ffi/gtk.janet b/examples/ffi/gtk.janet new file mode 100644 index 00000000..8657bace --- /dev/null +++ b/examples/ffi/gtk.janet @@ -0,0 +1,71 @@ +# :lazy true needed for jpm quickbin +# lazily loads library on first function use +# so the `main` function +# can be marshalled. +(ffi/context "/usr/lib/libgtk-3.so" :lazy true) + +(ffi/defbind + gtk-application-new :ptr + "Add docstrings as needed." + [title :string flags :uint]) + +(ffi/defbind + g-signal-connect-data :ulong + [a :ptr b :ptr c :ptr d :ptr e :ptr f :int]) + +(ffi/defbind + g-application-run :int + [app :ptr argc :int argv :ptr]) + +(ffi/defbind + gtk-application-window-new :ptr + [a :ptr]) + +(ffi/defbind + gtk-button-new-with-label :ptr + [a :ptr]) + +(ffi/defbind + gtk-container-add :void + [a :ptr b :ptr]) + +(ffi/defbind + gtk-widget-show-all :void + [a :ptr]) + +(ffi/defbind + gtk-button-set-label :void + [a :ptr b :ptr]) + +(def cb (delay (ffi/trampoline :default))) + +(defn ffi/array + ``Convert a janet array to a buffer that can be passed to FFI functions. + For example, to create an array of type `char *` (array of c strings), one + could use `(ffi/array ["hello" "world"] :ptr)`. One needs to be careful that + array elements are not garbage collected though - the GC can't follow references + inside an arbitrary byte buffer.`` + [arr ctype &opt buf] + (default buf @"") + (each el arr + (ffi/write ctype el buf)) + buf) + +(defn on-active + [app] + (def window (gtk-application-window-new app)) + (def btn (gtk-button-new-with-label "Click Me!")) + (g-signal-connect-data btn "clicked" (cb) + (fn [btn] (gtk-button-set-label btn "Hello World")) + nil 1) + (gtk-container-add window btn) + (gtk-widget-show-all window)) + +(defn main + [&] + (def app (gtk-application-new "org.janet-lang.example.HelloApp" 0)) + (g-signal-connect-data app "activate" (cb) on-active nil 1) + # manually build an array with ffi/write + # - we are responsible for preventing gc when the arg array is used + (def argv (ffi/array (dyn *args*) :string)) + (g-application-run app (length (dyn *args*)) argv)) diff --git a/examples/ffi/so.c b/examples/ffi/so.c new file mode 100644 index 00000000..2d1cc818 --- /dev/null +++ b/examples/ffi/so.c @@ -0,0 +1,87 @@ +#include +#include +#include + +int int_fn(int a, int b) { + return (a << 2) + b; +} + +double my_fn(int64_t a, int64_t b, const char *x) { + return (double)(a + b) + 0.5 + strlen(x); +} + +double double_fn(double x, double y, double z) { + return (x + y) * z * 3; +} + +double double_many(double x, double y, double z, double w, double a, double b) { + return x + y + z + w + a + b; +} + +double double_lots( + double a, + double b, + double c, + double d, + double e, + double f, + double g, + double h, + double i, + double j) { + return i + j; +} + +double float_fn(float x, float y, float z) { + return (x + y) * z; +} + +typedef struct { + int a; + int b; +} intint; + +typedef struct { + int a; + int b; + int c; +} intintint; + +int intint_fn(double x, intint ii) { + printf("double: %g\n", x); + return ii.a + ii.b; +} + +int intintint_fn(double x, intintint iii) { + printf("double: %g\n", x); + return iii.a + iii.b + iii.c; +} + +intint return_struct(int i) { + intint ret; + ret.a = i; + ret.b = i * i; + return ret; +} + +typedef struct { + int64_t a; + int64_t b; + int64_t c; +} big; + +big struct_big(int i, double d) { + big ret; + ret.a = i; + ret.b = (int64_t) d; + ret.c = ret.a + ret.b + 1000; + return ret; +} + +void void_fn(void) { + printf("void fn ran\n"); +} + +void void_ret_fn(int x) { + printf("void fn ran: %d\n", x); +} diff --git a/examples/ffi/test.janet b/examples/ffi/test.janet new file mode 100644 index 00000000..dccc4018 --- /dev/null +++ b/examples/ffi/test.janet @@ -0,0 +1,132 @@ +# +# Simple FFI test script that tests against a simple shared object +# + +(def ffi/loc "examples/ffi/so.so") +(def ffi/source-loc "examples/ffi/so.c") + +(os/execute ["cc" ffi/source-loc "-shared" "-o" ffi/loc] :px) +(def module (ffi/native ffi/loc)) + +(def int-fn-sig (ffi/signature :default :int :int :int)) +(def int-fn-pointer (ffi/lookup module "int_fn")) +(defn int-fn + [x y] + (ffi/call int-fn-pointer int-fn-sig x y)) + +(def double-fn-sig (ffi/signature :default :double :double :double :double)) +(def double-fn-pointer (ffi/lookup module "double_fn")) +(defn double-fn + [x y z] + (ffi/call double-fn-pointer double-fn-sig x y z)) + +(def double-many-sig (ffi/signature :default :double :double :double :double :double :double :double)) +(def double-many-pointer (ffi/lookup module "double_many")) +(defn double-many + [x y z w a b] + (ffi/call double-many-pointer double-many-sig x y z w a b)) + +(def double-lots-sig (ffi/signature :default :double + :double :double :double :double :double + :double :double :double :double :double)) +(def double-lots-pointer (ffi/lookup module "double_lots")) +(defn double-lots + [a b c d e f g h i j] + (ffi/call double-lots-pointer double-lots-sig a b c d e f g h i j)) + +(def float-fn-sig (ffi/signature :default :double :float :float :float)) +(def float-fn-pointer (ffi/lookup module "float_fn")) +(defn float-fn + [x y z] + (ffi/call float-fn-pointer float-fn-sig x y z)) + +(def intint-fn-sig (ffi/signature :default :int :double [:int :int])) +(def intint-fn-pointer (ffi/lookup module "intint_fn")) +(defn intint-fn + [x ii] + (ffi/call intint-fn-pointer intint-fn-sig x ii)) + +(def return-struct-sig (ffi/signature :default [:int :int] :int)) +(def return-struct-pointer (ffi/lookup module "return_struct")) +(defn return-struct-fn + [i] + (ffi/call return-struct-pointer return-struct-sig i)) + +(def intintint (ffi/struct :int :int :int)) +(def intintint-fn-sig (ffi/signature :default :int :double intintint)) +(def intintint-fn-pointer (ffi/lookup module "intintint_fn")) +(defn intintint-fn + [x iii] + (ffi/call intintint-fn-pointer intintint-fn-sig x iii)) + +(def big (ffi/struct :s64 :s64 :s64)) +(def struct-big-fn-sig (ffi/signature :default big :int :double)) +(def struct-big-fn-pointer (ffi/lookup module "struct_big")) +(defn struct-big-fn + [i d] + (ffi/call struct-big-fn-pointer struct-big-fn-sig i d)) + +(def void-fn-pointer (ffi/lookup module "void_fn")) +(def void-fn-sig (ffi/signature :default :void)) +(defn void-fn + [] + (ffi/call void-fn-pointer void-fn-sig)) + +# +# Call functions +# + +(pp (void-fn)) +(pp (int-fn 10 20)) +(pp (double-fn 1.5 2.5 3.5)) +(pp (double-many 1 2 3 4 5 6)) +(pp (double-lots 1 2 3 4 5 6 7 8 9 10)) +(pp (float-fn 8 4 17)) +(pp (intint-fn 123.456 [10 20])) +(pp (intintint-fn 123.456 [10 20 30])) +(pp (return-struct-fn 42)) +(pp (struct-big-fn 11 99.5)) + +(assert (= 60 (int-fn 10 20))) +(assert (= 42 (double-fn 1.5 2.5 3.5))) +(assert (= 21 (double-many 1 2 3 4 5 6))) +(assert (= 19 (double-lots 1 2 3 4 5 6 7 8 9 10))) +(assert (= 204 (float-fn 8 4 17))) + +# +# Struct reading and writing +# + +(defn check-round-trip + [t value] + (def buf (ffi/write t value)) + (def same-value (ffi/read t buf)) + (assert (deep= value same-value) + (string/format "round trip %j (got %j)" value same-value))) + +(check-round-trip :bool true) +(check-round-trip :bool false) +(check-round-trip :void nil) +(check-round-trip :void nil) +(check-round-trip :s8 10) +(check-round-trip :s8 0) +(check-round-trip :s8 -10) +(check-round-trip :u8 10) +(check-round-trip :u8 0) +(check-round-trip :s16 10) +(check-round-trip :s16 0) +(check-round-trip :s16 -12312) +(check-round-trip :u16 10) +(check-round-trip :u16 0) +(check-round-trip :u32 0) +(check-round-trip :u32 10) +(check-round-trip :u32 0xFFFF7777) +(check-round-trip :s32 0x7FFF7777) +(check-round-trip :s32 0) +(check-round-trip :s32 -1234567) + +(def s (ffi/struct :s8 :s8 :s8 :float)) +(check-round-trip s [1 3 5 123.5]) +(check-round-trip s [-1 -3 -5 -123.5]) + +(print "Done.") diff --git a/meson.build b/meson.build index b28f33ca..49fc233a 100644 --- a/meson.build +++ b/meson.build @@ -20,7 +20,7 @@ project('janet', 'c', default_options : ['c_std=c99', 'build.c_std=c99', 'b_lundef=false', 'default_library=both'], - version : '1.22.0') + version : '1.23.1') # Global settings janet_path = join_paths(get_option('prefix'), get_option('libdir'), 'janet') @@ -76,6 +76,7 @@ conf.set('JANET_SIMPLE_GETLINE', get_option('simple_getline')) conf.set('JANET_EV_NO_EPOLL', not get_option('epoll')) conf.set('JANET_EV_NO_KQUEUE', not get_option('kqueue')) conf.set('JANET_NO_INTERPRETER_INTERRUPT', not get_option('interpreter_interrupt')) +conf.set('JANET_NO_FFI', not get_option('ffi')) if get_option('os_name') != '' conf.set('JANET_OS_NAME', get_option('os_name')) endif @@ -116,6 +117,7 @@ core_src = [ 'src/core/debug.c', 'src/core/emit.c', 'src/core/ev.c', + 'src/core/ffi.c', 'src/core/fiber.c', 'src/core/gc.c', 'src/core/inttypes.c', @@ -265,4 +267,7 @@ patched_janet = custom_target('patched-janeth', command : [janet_nativeclient, '@INPUT@', '@OUTPUT@']) # Create a version of the janet.h header that matches what jpm often expects -install_symlink('janet.h', pointing_to: 'janet/janet.h', install_dir: get_option('includedir')) +if meson.version().version_compare('>=0.61') + install_symlink('janet.h', pointing_to: 'janet/janet.h', install_dir: get_option('includedir')) +endif + diff --git a/meson_options.txt b/meson_options.txt index afc8f353..315bf365 100644 --- a/meson_options.txt +++ b/meson_options.txt @@ -19,6 +19,7 @@ option('simple_getline', type : 'boolean', value : false) 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('recursion_guard', type : 'integer', min : 10, max : 8000, value : 1024) option('max_proto_depth', type : 'integer', min : 10, max : 8000, value : 200) diff --git a/src/boot/boot.janet b/src/boot/boot.janet index 546a7461..fe3386ce 100644 --- a/src/boot/boot.janet +++ b/src/boot/boot.janet @@ -1,5 +1,5 @@ # The core janet library -# Copyright 2021 © Calvin Rose +# Copyright 2022 © Calvin Rose ### ### @@ -45,6 +45,7 @@ (defn defmacro :macro "Define a macro." [name & more] + (setdyn name @{}) # override old macro definitions in the case of a recursive macro (apply defn name :macro more)) (defmacro as-macro @@ -162,7 +163,7 @@ (def ,v ,x) (if ,v ,v - (,error ,(if err err "assert failure"))))) + (,error ,(if err err (string/format "assert failure in %j" x)))))) (defn errorf "A combination of `error` and `string/format`. Equivalent to `(error (string/format fmt ;args))`." @@ -610,13 +611,20 @@ See `loop` for details.`` [head & body] (def $accum (gensym)) - ~(do (def ,$accum @[]) (loop ,head (array/push ,$accum (do ,;body))) ,$accum)) + ~(do (def ,$accum @[]) (loop ,head (,array/push ,$accum (do ,;body))) ,$accum)) + +(defmacro tabseq + ``Similar to `loop`, but accumulates key value pairs into a table. + See `loop` for details.`` + [head key-body & value-body] + (def $accum (gensym)) + ~(do (def ,$accum @{}) (loop ,head (,put ,$accum ,key-body (do ,;value-body))) ,$accum)) (defmacro generate ``Create a generator expression using the `loop` syntax. Returns a fiber that yields all values inside the loop in order. See `loop` for details.`` [head & body] - ~(fiber/new (fn [] (loop ,head (yield (do ,;body)))) :yi)) + ~(,fiber/new (fn [] (loop ,head (yield (do ,;body)))) :yi)) (defmacro coro "A wrapper for making fibers that may yield multiple values (coroutine). Same as `(fiber/new (fn [] ;body) :yi)`." @@ -953,12 +961,12 @@ (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)))))) + (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)))) @@ -1596,8 +1604,8 @@ (each x ind (def y (f x)) (cond - is-new (do (set is-new false) (set category y) (set span @[x]) (array/push ret span)) - (= y category) (array/push span x) + is-new (do (set is-new false) (set category y) (set span @[x]) (array/push ret span)) + (= y category) (array/push span x) (do (set category y) (set span @[x]) (array/push ret span)))) ret) @@ -1847,7 +1855,7 @@ (when isarr (array/push anda (get-length-sym s)) (def pattern-len - (if-let [ rest-idx (find-index (fn [x] (= x '&)) pattern) ] + (if-let [rest-idx (find-index (fn [x] (= x '&)) pattern)] rest-idx (length pattern))) (array/push anda [<= pattern-len (get-length-sym s)])) @@ -2287,9 +2295,9 @@ (def source-code (file/read f :all)) (var index 0) (repeat (dec line) - (if-not index (break)) - (set index (string/find "\n" source-code index)) - (if index (++ index))) + (if-not index (break)) + (set index (string/find "\n" source-code index)) + (if index (++ index))) (when index (def line-end (string/find "\n" source-code index)) (eprint " " (string/slice source-code index line-end)) @@ -2580,6 +2588,20 @@ (error (parser/error p)) (error "no value"))))) +(defn parse-all + `Parse a string and return all parsed values. For complex parsing, such as for a repl with error handling, + use the parser api.` + [str] + (let [p (parser/new) + ret @[]] + (parser/consume p str) + (parser/eof p) + (while (parser/has-more p) + (array/push ret (parser/produce p))) + (if (= :error (parser/status p)) + (error (parser/error p)) + 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)`.`` @@ -2737,19 +2759,64 @@ (get r 0) v)))) +(def debugger-env + "An environment that contains dot prefixed functions for debugging." + @{}) + +(var- debugger-on-status-var nil) + +(defn debugger + "Run a repl-based debugger on a fiber. Optionally pass in a level + to differentiate nested debuggers." + [fiber &opt level] + (default level 1) + (def nextenv (make-env (fiber/getenv fiber))) + (put nextenv :fiber fiber) + (put nextenv :debug-level level) + (put nextenv :signal (fiber/last-value fiber)) + (merge-into nextenv debugger-env) + (defn debugger-chunks [buf p] + (def status (:state p :delimiters)) + (def c ((:where p) 0)) + (def prpt (string "debug[" level "]:" c ":" status "> ")) + (getline prpt buf nextenv)) + (eprint "entering debug[" level "] - (quit) to exit") + (flush) + (run-context + {:chunks debugger-chunks + :on-status (debugger-on-status-var nextenv (+ 1 level) true) + :env nextenv}) + (eprint "exiting debug[" level "]") + (flush) + (nextenv :resume-value)) + +(defn debugger-on-status + "Create a function that can be passed to `run-context`'s `:on-status` + argument that will drop into a debugger on errors. The debugger will + only start on abnormal signals if the env table has the `:debug` dyn + set to a truthy value." + [env &opt level is-repl] + (default level 1) + (fn [f x] + (def fs (fiber/status f)) + (if (= :dead fs) + (when is-repl + (put env '_ @{:value x}) + (printf (get env :pretty-format "%q") x) + (flush)) + (do + (debug/stacktrace f x "") + (eflush) + (if (get env :debug) (debugger f level)))))) + +(set debugger-on-status-var debugger-on-status) + (defn dofile ``Evaluate a file, file path, or stream and return the resulting environment. :env, :expander, :source, :evaluator, :read, and :parser are passed through to the underlying `run-context` call. If `exit` is true, any top level errors will trigger a call to `(os/exit 1)` after printing the error.`` - [path &keys - {:exit exit - :env env - :source src - :expander expander - :evaluator evaluator - :read read - :parser parser}] + [path &named exit env source expander evaluator read parser] (def f (case (type path) :core/file path :core/stream path @@ -2757,7 +2824,7 @@ (def path-is-file (= f path)) (default env (make-env)) (def spath (string path)) - (put env :source (or src (if-not path-is-file spath path))) + (put env :source (or source (if-not path-is-file spath path))) (var exit-error nil) (var exit-fiber nil) (defn chunks [buf _] (:read f 4096 buf)) @@ -2793,14 +2860,17 @@ (debug/stacktrace f x "") (eflush) (os/exit 1)) - (put env :exit true) - (set exit-error x) - (set exit-fiber f))) + (if (get env :debug) + ((debugger-on-status env) f x) + (do + (put env :exit true) + (set exit-error x) + (set exit-fiber f))))) :evaluator evaluator :expander expander :read read :parser parser - :source (or src (if path-is-file : spath))})) + :source (or source (if path-is-file : spath))})) (if-not path-is-file (:close f)) (when exit-error (if exit-fiber @@ -2963,7 +3033,7 @@ # Parse state (var cursor 0) # indexes into string for parsing - (var stack @[]) # return value for this block. + (var stack @[]) # return value for this block. # Traversal helpers (defn c [] (get str cursor)) @@ -3082,38 +3152,40 @@ (= b (chr "_")) (delim :underline) (= b (chr "`")) (delim :code) (= 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)))) (endtoken) (tuple/slice tokens)) - (set parse-blocks (fn parse-blocks [indent] - (var new-indent indent) - (var p-start nil) - (var p-end nil) - (defn p-line [] - (unless p-start - (set p-start cursor)) - (skipline) - (set p-end cursor) - (set new-indent (skipwhite))) - (defn finish-p [] - (when (and p-start (> p-end p-start)) - (push (tokenize-line (getslice p-start p-end))) - (set p-start nil))) - (while (and (c) (>= new-indent indent)) - (cond - (nl?) (do (finish-p) (c++) (set new-indent (skipwhite))) - (ul?) (do (finish-p) (set new-indent (parse-list ul? :ul new-indent))) - (ol?) (do (finish-p) (set new-indent (parse-list ol? :ol new-indent))) - (fcb?) (do (finish-p) (set new-indent (parse-fcb new-indent))) - (>= new-indent (+ 4 indent)) (do (finish-p) (set new-indent (parse-icb new-indent))) - (p-line))) - (finish-p) - new-indent)) + (set + parse-blocks + (fn parse-blocks [indent] + (var new-indent indent) + (var p-start nil) + (var p-end nil) + (defn p-line [] + (unless p-start + (set p-start cursor)) + (skipline) + (set p-end cursor) + (set new-indent (skipwhite))) + (defn finish-p [] + (when (and p-start (> p-end p-start)) + (push (tokenize-line (getslice p-start p-end))) + (set p-start nil))) + (while (and (c) (>= new-indent indent)) + (cond + (nl?) (do (finish-p) (c++) (set new-indent (skipwhite))) + (ul?) (do (finish-p) (set new-indent (parse-list ul? :ul new-indent))) + (ol?) (do (finish-p) (set new-indent (parse-list ol? :ol new-indent))) + (fcb?) (do (finish-p) (set new-indent (parse-fcb new-indent))) + (>= new-indent (+ 4 indent)) (do (finish-p) (set new-indent (parse-icb new-indent))) + (p-line))) + (finish-p) + new-indent)) # Handle first line specially for defn, defmacro, etc. (when (= (chr "(") (in str 0)) @@ -3250,10 +3322,10 @@ (do (def [fullpath mod-kind] (module/find (string sym))) (if-let [mod-env (in module/cache fullpath)] - (print-module-entry {:module true - :kind mod-kind + (print-module-entry {:module true + :kind mod-kind :source-map [fullpath nil nil] - :doc (in mod-env :doc)}) + :doc (in mod-env :doc)}) (print "symbol " sym " not found.")))) (print-module-entry x))) @@ -3353,25 +3425,26 @@ (def pc (frame :pc)) (def sourcemap (in dasm :sourcemap)) (var last-loc [-2 -2]) - (print "\n signal: " (.signal)) - (print " function: " (dasm :name) " [" (in dasm :source "") "]") + (eprint "\n signal: " (.signal)) + (eprint " status: " (fiber/status (.fiber))) + (eprint " function: " (get dasm :name "") " [" (in dasm :source "") "]") (when-let [constants (dasm :constants)] - (printf " constants: %.4q" constants)) - (printf " slots: %.4q\n" (frame :slots)) + (eprintf " constants: %.4q" constants)) + (eprintf " slots: %.4q\n" (frame :slots)) (def padding (string/repeat " " 20)) (loop [i :range [0 (length bytecode)] :let [instr (bytecode i)]] - (prin (if (= (tuple/type instr) :brackets) "*" " ")) - (prin (if (= i pc) "> " " ")) - (prinf "%.20s" (string (string/join (map string instr) " ") padding)) + (eprin (if (= (tuple/type instr) :brackets) "*" " ")) + (eprin (if (= i pc) "> " " ")) + (eprinf "%.20s" (string (string/join (map string instr) " ") padding)) (when sourcemap (let [[sl sc] (sourcemap i) loc [sl sc]] (when (not= loc last-loc) (set last-loc loc) - (prin " # line " sl ", column " sc)))) - (print)) - (print)) + (eprin " # line " sl ", column " sc)))) + (eprint)) + (eprint)) (defn .breakall "Set breakpoints on all instructions in the current function." @@ -3380,7 +3453,7 @@ (def bytecode (.bytecode n)) (forv i 0 (length bytecode) (debug/fbreak fun i)) - (print "Set " (length bytecode) " breakpoints in " fun)) + (eprint "set " (length bytecode) " breakpoints in " fun)) (defn .clearall "Clear all breakpoints on the current function." @@ -3389,7 +3462,7 @@ (def bytecode (.bytecode n)) (forv i 0 (length bytecode) (debug/unfbreak fun i)) - (print "Cleared " (length bytecode) " breakpoints in " fun))) + (eprint "cleared " (length bytecode) " breakpoints in " fun))) (defn .source "Show the source code for the function being debugged." @@ -3397,7 +3470,7 @@ (def frame (.frame n)) (def s (frame :source)) (def all-source (slurp s)) - (print "\n" all-source "\n")) + (eprint "\n" all-source "\n")) (defn .break "Set breakpoint at the current pc." @@ -3406,7 +3479,7 @@ (def fun (frame :function)) (def pc (frame :pc)) (debug/fbreak fun pc) - (print "Set breakpoint in " fun " at pc=" pc)) + (eprint "set breakpoint in " fun " at pc=" pc)) (defn .clear "Clear the current breakpoint." @@ -3415,7 +3488,7 @@ (def fun (frame :function)) (def pc (frame :pc)) (debug/unfbreak fun pc) - (print "Cleared breakpoint in " fun " at pc=" pc)) + (eprint "cleared breakpoint in " fun " at pc=" pc)) (defn .next "Go to the next breakpoint." @@ -3439,10 +3512,6 @@ (set res (debug/step (.fiber)))) res) -(def debugger-env - "An environment that contains dot prefixed functions for debugging." - @{}) - (def- debugger-keys (filter (partial string/has-prefix? ".") (keys root-env))) (each k debugger-keys (put debugger-env k (root-env k)) (put root-env k nil)) @@ -3470,43 +3539,9 @@ ":" (:state p :delimiters) "> ") buf env))) - (defn make-onsignal - [e level] - - (defn enter-debugger - [f x] - (def nextenv (make-env env)) - (put nextenv :fiber f) - (put nextenv :debug-level level) - (put nextenv :signal x) - (merge-into nextenv debugger-env) - (defn debugger-chunks [buf p] - (def status (:state p :delimiters)) - (def c ((:where p) 0)) - (def prpt (string "debug[" level "]:" c ":" status "> ")) - (getline prpt buf nextenv)) - (print "entering debug[" level "] - (quit) to exit") - (flush) - (repl debugger-chunks (make-onsignal nextenv (+ 1 level)) nextenv) - (print "exiting debug[" level "]") - (flush) - (nextenv :resume-value)) - - (fn [f x] - (def fs (fiber/status f)) - (if (= :dead fs) - (do - (put e '_ @{:value x}) - (printf (get e :pretty-format "%q") x) - (flush)) - (do - (debug/stacktrace f x "") - (eflush) - (if (e :debug) (enter-debugger f x)))))) - (run-context {:env env :chunks chunks - :on-status (or onsignal (make-onsignal env 1)) + :on-status (or onsignal (debugger-on-status env 1 true)) :parser parser :read read :source :repl})) @@ -3573,8 +3608,8 @@ (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] + ~(,ev/go (fn [] (put ,res ,i ,body)) nil ,chan))) ,res)))) (compwhen (dyn 'net/listen) @@ -3586,6 +3621,74 @@ (ev/call (fn [] (net/accept-loop s handler)))) s)) +### +### +### FFI Extra +### +### + +(defmacro delay + "Lazily evaluate a series of expressions. Returns a function that + returns the result of the last expression. Will only evaluate the + body once, and then memoizes the result." + [& forms] + (def state (gensym)) + (def loaded (gensym)) + ~((fn [] + (var ,state nil) + (var ,loaded nil) + (fn [] + (if ,loaded + ,state + (do + (set ,loaded true) + (set ,state (do ,;forms)))))))) + +(compwhen (dyn 'ffi/native) + + (defdyn *ffi-context* " Current native library for ffi/bind and other settings") + + (defn- default-mangle + [name &] + (string/replace-all "-" "_" name)) + + (defn ffi/context + "Set the path of the dynamic library to implictly bind, as well + as other global state for ease of creating native bindings." + [&opt native-path &named map-symbols lazy] + (default map-symbols default-mangle) + (def lib (if lazy nil (ffi/native native-path))) + (def lazy-lib (if lazy (delay (ffi/native native-path)))) + (setdyn *ffi-context* + @{:native-path native-path + :native lib + :native-lazy lazy-lib + :lazy lazy + :map-symbols map-symbols})) + + (defmacro ffi/defbind + "Generate bindings for native functions in a convenient manner." + [name ret-type & body] + (def meta (slice body 0 -2)) + (def arg-pairs (partition 2 (last body))) + (def formal-args (map 0 arg-pairs)) + (def type-args (map 1 arg-pairs)) + (def computed-type-args (eval ~[,;type-args])) + (def {:native lib + :lazy lazy + :native-lazy llib + :map-symbols ms} (assert (dyn *ffi-context*) "no ffi context found")) + (def raw-symbol (ms name)) + (defn make-sig [] + (ffi/signature :default ret-type ;computed-type-args)) + (defn make-ptr [] + (assert (ffi/lookup (if lazy (llib) lib) raw-symbol) "failed to find 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))))) + ### ### ### Flychecking @@ -3656,7 +3759,7 @@ (try (dofile path :evaluator flycheck-evaluator ;(kvs kwargs)) ([e f] - (debug/stacktrace f e ""))) + (debug/stacktrace f e ""))) (table/clear module/cache) (merge-into module/cache old-modcache) nil) @@ -3673,10 +3776,18 @@ (defn- run-main [env subargs arg] - (if-let [entry (in env 'main) - main (or (get entry :value) (in (get entry :ref) 0))] - (let [thunk (compile [main ;subargs] env arg)] - (if (function? thunk) (thunk) (error (thunk :error)))))) + (when-let [entry (in env 'main) + main (or (get entry :value) (in (get entry :ref) 0))] + (def guard (if (get env :debug) :ydt :y)) + (defn wrap-main [&] + (main ;subargs)) + (def f (fiber/new wrap-main guard)) + (fiber/setenv f env) + (var res nil) + (while (fiber/can-resume? f) + (set res (resume f res)) + (when (not= :dead (fiber/status f)) + ((debugger-on-status env) f res))))) (defdyn *args* "Dynamic bindings that will contain command line arguments at program start.") @@ -3838,8 +3949,8 @@ (file/read stdin :line buf)) (def env (make-env)) (when-let [profile.janet (dyn *profilepath*)] - (def new-env (dofile profile.janet :exit true)) - (merge-module env new-env "" false)) + (def new-env (dofile profile.janet :exit true)) + (merge-module env new-env "" false)) (when debug-flag (put env *debug* true) (put env *redef* true)) @@ -3861,10 +3972,6 @@ (do - # Deprecate file/popen - (when-let [v (get root-env 'file/popen)] - (put v :deprecated true)) - # Modify root-env to remove private symbols and # flatten nested tables. (loop [[k v] :in (pairs root-env) @@ -3929,6 +4036,7 @@ "src/core/debug.c" "src/core/emit.c" "src/core/ev.c" + "src/core/ffi.c" "src/core/fiber.c" "src/core/gc.c" "src/core/inttypes.c" diff --git a/src/conf/janetconf.h b/src/conf/janetconf.h index 6a651ae3..f6e56361 100644 --- a/src/conf/janetconf.h +++ b/src/conf/janetconf.h @@ -4,10 +4,10 @@ #define JANETCONF_H #define JANET_VERSION_MAJOR 1 -#define JANET_VERSION_MINOR 22 -#define JANET_VERSION_PATCH 0 -#define JANET_VERSION_EXTRA "" -#define JANET_VERSION "1.22.0" +#define JANET_VERSION_MINOR 23 +#define JANET_VERSION_PATCH 1 +#define JANET_VERSION_EXTRA "-dev" +#define JANET_VERSION "1.23.1-dev" /* #define JANET_BUILD "local" */ diff --git a/src/core/abstract.c b/src/core/abstract.c index b568fb20..20d43f34 100644 --- a/src/core/abstract.c +++ b/src/core/abstract.c @@ -23,14 +23,16 @@ #ifndef JANET_AMALG #include "features.h" #include +#include "util.h" #include "gc.h" #include "state.h" +#endif + #ifdef JANET_EV #ifdef JANET_WINDOWS #include #endif #endif -#endif /* Create new userdata */ void *janet_abstract_begin(const JanetAbstractType *atype, size_t size) { @@ -85,6 +87,14 @@ void *janet_abstract_threaded(const JanetAbstractType *atype, size_t size) { #ifdef JANET_WINDOWS +size_t janet_os_mutex_size(void) { + return sizeof(CRITICAL_SECTION); +} + +size_t janet_os_rwlock_size(void) { + return sizeof(void *); +} + static int32_t janet_incref(JanetAbstractHead *ab) { return InterlockedIncrement(&ab->gc.data.refcount); } @@ -106,11 +116,45 @@ void janet_os_mutex_lock(JanetOSMutex *mutex) { } void janet_os_mutex_unlock(JanetOSMutex *mutex) { + /* error handling? May want to keep counter */ LeaveCriticalSection((CRITICAL_SECTION *) mutex); } +void janet_os_rwlock_init(JanetOSRWLock *rwlock) { + InitializeSRWLock((PSRWLOCK) rwlock); +} + +void janet_os_rwlock_deinit(JanetOSRWLock *rwlock) { + /* no op? */ + (void) rwlock; +} + +void janet_os_rwlock_rlock(JanetOSRWLock *rwlock) { + AcquireSRWLockShared((PSRWLOCK) rwlock); +} + +void janet_os_rwlock_wlock(JanetOSRWLock *rwlock) { + AcquireSRWLockExclusive((PSRWLOCK) rwlock); +} + +void janet_os_rwlock_runlock(JanetOSRWLock *rwlock) { + ReleaseSRWLockShared((PSRWLOCK) rwlock); +} + +void janet_os_rwlock_wunlock(JanetOSRWLock *rwlock) { + ReleaseSRWLockExclusive((PSRWLOCK) rwlock); +} + #else +size_t janet_os_mutex_size(void) { + return sizeof(pthread_mutex_t); +} + +size_t janet_os_rwlock_size(void) { + return sizeof(pthread_rwlock_t); +} + static int32_t janet_incref(JanetAbstractHead *ab) { return __atomic_add_fetch(&ab->gc.data.refcount, 1, __ATOMIC_RELAXED); } @@ -120,19 +164,47 @@ static int32_t janet_decref(JanetAbstractHead *ab) { } void janet_os_mutex_init(JanetOSMutex *mutex) { - pthread_mutex_init(mutex, NULL); + pthread_mutexattr_t attr; + pthread_mutexattr_init(&attr); + pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE); + pthread_mutex_init((pthread_mutex_t *) mutex, &attr); } void janet_os_mutex_deinit(JanetOSMutex *mutex) { - pthread_mutex_destroy(mutex); + pthread_mutex_destroy((pthread_mutex_t *) mutex); } void janet_os_mutex_lock(JanetOSMutex *mutex) { - pthread_mutex_lock(mutex); + pthread_mutex_lock((pthread_mutex_t *) mutex); } void janet_os_mutex_unlock(JanetOSMutex *mutex) { - pthread_mutex_unlock(mutex); + int ret = pthread_mutex_unlock((pthread_mutex_t *) mutex); + if (ret) janet_panic("cannot release lock"); +} + +void janet_os_rwlock_init(JanetOSRWLock *rwlock) { + pthread_rwlock_init((pthread_rwlock_t *) rwlock, NULL); +} + +void janet_os_rwlock_deinit(JanetOSRWLock *rwlock) { + pthread_rwlock_destroy((pthread_rwlock_t *) rwlock); +} + +void janet_os_rwlock_rlock(JanetOSRWLock *rwlock) { + pthread_rwlock_rdlock((pthread_rwlock_t *) rwlock); +} + +void janet_os_rwlock_wlock(JanetOSRWLock *rwlock) { + pthread_rwlock_wrlock((pthread_rwlock_t *) rwlock); +} + +void janet_os_rwlock_runlock(JanetOSRWLock *rwlock) { + pthread_rwlock_unlock((pthread_rwlock_t *) rwlock); +} + +void janet_os_rwlock_wunlock(JanetOSRWLock *rwlock) { + pthread_rwlock_unlock((pthread_rwlock_t *) rwlock); } #endif diff --git a/src/core/asm.c b/src/core/asm.c index b82389fd..95785e48 100644 --- a/src/core/asm.c +++ b/src/core/asm.c @@ -553,6 +553,10 @@ static JanetAssembleResult janet_asm1(JanetAssembler *parent, Janet source, int x = janet_get1(s, janet_ckeywordv("vararg")); if (janet_truthy(x)) def->flags |= JANET_FUNCDEF_FLAG_VARARG; + /* Check structarg */ + x = janet_get1(s, janet_ckeywordv("structarg")); + if (janet_truthy(x)) def->flags |= JANET_FUNCDEF_FLAG_STRUCTARG; + /* Check source */ x = janet_get1(s, janet_ckeywordv("source")); if (janet_checktype(x, JANET_STRING)) def->source = janet_unwrap_string(x); @@ -884,6 +888,10 @@ static Janet janet_disasm_vararg(JanetFuncDef *def) { return janet_wrap_boolean(def->flags & JANET_FUNCDEF_FLAG_VARARG); } +static Janet janet_disasm_structarg(JanetFuncDef *def) { + return janet_wrap_boolean(def->flags & JANET_FUNCDEF_FLAG_STRUCTARG); +} + static Janet janet_disasm_constants(JanetFuncDef *def) { JanetArray *constants = janet_array(def->constants_length); for (int32_t i = 0; i < def->constants_length; i++) { @@ -933,6 +941,7 @@ Janet janet_disasm(JanetFuncDef *def) { janet_table_put(ret, janet_ckeywordv("bytecode"), janet_disasm_bytecode(def)); janet_table_put(ret, janet_ckeywordv("source"), janet_disasm_source(def)); janet_table_put(ret, janet_ckeywordv("vararg"), janet_disasm_vararg(def)); + janet_table_put(ret, janet_ckeywordv("structarg"), janet_disasm_structarg(def)); janet_table_put(ret, janet_ckeywordv("name"), janet_disasm_name(def)); janet_table_put(ret, janet_ckeywordv("slotcount"), janet_disasm_slotcount(def)); janet_table_put(ret, janet_ckeywordv("constants"), janet_disasm_constants(def)); @@ -986,6 +995,7 @@ JANET_CORE_FN(cfun_disasm, if (!janet_cstrcmp(kw, "source")) return janet_disasm_source(f->def); if (!janet_cstrcmp(kw, "name")) return janet_disasm_name(f->def); if (!janet_cstrcmp(kw, "vararg")) return janet_disasm_vararg(f->def); + if (!janet_cstrcmp(kw, "structarg")) return janet_disasm_structarg(f->def); if (!janet_cstrcmp(kw, "slotcount")) return janet_disasm_slotcount(f->def); if (!janet_cstrcmp(kw, "constants")) return janet_disasm_constants(f->def); if (!janet_cstrcmp(kw, "sourcemap")) return janet_disasm_sourcemap(f->def); diff --git a/src/core/capi.c b/src/core/capi.c index c7964f5a..c80c7304 100644 --- a/src/core/capi.c +++ b/src/core/capi.c @@ -260,11 +260,27 @@ int32_t janet_getinteger(const Janet *argv, int32_t n) { } int64_t janet_getinteger64(const Janet *argv, int32_t n) { +#ifdef JANET_INTTYPES + return janet_unwrap_s64(argv[n]); +#else Janet x = argv[n]; if (!janet_checkint64(x)) { janet_panicf("bad slot #%d, expected 64 bit signed integer, got %v", n, x); } return (int64_t) janet_unwrap_number(x); +#endif +} + +uint64_t janet_getuinteger64(const Janet *argv, int32_t n) { +#ifdef JANET_INTTYPES + return janet_unwrap_u64(argv[n]); +#else + Janet x = argv[n]; + if (!janet_checkint64(x)) { + janet_panicf("bad slot #%d, expected 64 bit unsigned integer, got %v", n, x); + } + return (uint64_t) janet_unwrap_number(x); +#endif } size_t janet_getsize(const Janet *argv, int32_t n) { diff --git a/src/core/corelib.c b/src/core/corelib.c index f250a6d1..dcde0c45 100644 --- a/src/core/corelib.c +++ b/src/core/corelib.c @@ -42,51 +42,6 @@ extern size_t janet_core_image_size; #define JDOC(x) NULL #endif -/* Use LoadLibrary on windows or dlopen on posix to load dynamic libaries - * with native code. */ -#if defined(JANET_NO_DYNAMIC_MODULES) -typedef int Clib; -#define load_clib(name) ((void) name, 0) -#define symbol_clib(lib, sym) ((void) lib, (void) sym, NULL) -#define error_clib() "dynamic libraries not supported" -#elif defined(JANET_WINDOWS) -#include -typedef HINSTANCE Clib; -#define load_clib(name) LoadLibrary((name)) -#define symbol_clib(lib, sym) GetProcAddress((lib), (sym)) -static char error_clib_buf[256]; -static char *error_clib(void) { - FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, - NULL, GetLastError(), MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), - error_clib_buf, sizeof(error_clib_buf), NULL); - error_clib_buf[strlen(error_clib_buf) - 1] = '\0'; - return error_clib_buf; -} -#else -#include -typedef void *Clib; -#define load_clib(name) dlopen((name), RTLD_NOW) -#define symbol_clib(lib, sym) dlsym((lib), (sym)) -#define error_clib() dlerror() -#endif - -static char *get_processed_name(const char *name) { - if (name[0] == '.') return (char *) name; - const char *c; - for (c = name; *c; c++) { - if (*c == '/') return (char *) name; - } - size_t l = (size_t)(c - name); - char *ret = janet_malloc(l + 3); - if (NULL == ret) { - JANET_OUT_OF_MEMORY; - } - ret[0] = '.'; - ret[1] = '/'; - memcpy(ret + 2, name, l + 1); - return ret; -} - JanetModule janet_native(const char *name, const uint8_t **error) { char *processed_name = get_processed_name(name); Clib lib = load_clib(processed_name); @@ -1016,6 +971,9 @@ static void janet_load_libs(JanetTable *env) { #ifdef JANET_NET janet_lib_net(env); #endif +#ifdef JANET_FFI + janet_lib_ffi(env); +#endif } #ifdef JANET_BOOTSTRAP diff --git a/src/core/ev.c b/src/core/ev.c index 70860826..84c631c4 100644 --- a/src/core/ev.c +++ b/src/core/ev.c @@ -79,7 +79,11 @@ typedef struct { int32_t limit; int closed; int is_threaded; - JanetOSMutex lock; +#ifdef JANET_WINDOWS + CRITICAL_SECTION lock; +#else + pthread_mutex_t lock; +#endif } JanetChannel; typedef struct { @@ -531,10 +535,15 @@ static int janet_channel_push(JanetChannel *channel, Janet x, int mode); static int janet_channel_pop(JanetChannel *channel, Janet *item, int is_choice); static Janet make_supervisor_event(const char *name, JanetFiber *fiber, int threaded) { - Janet tup[2]; + Janet tup[3]; tup[0] = janet_ckeywordv(name); tup[1] = threaded ? fiber->last_value : janet_wrap_fiber(fiber) ; - return janet_wrap_tuple(janet_tuple_n(tup, 2)); + if (fiber->env != NULL) { + tup[2] = janet_table_get(fiber->env, janet_ckeywordv("task-id")); + } else { + tup[2] = janet_wrap_nil(); + } + return janet_wrap_tuple(janet_tuple_n(tup, 3)); } /* Common init code */ @@ -643,7 +652,7 @@ static void janet_chan_init(JanetChannel *chan, int32_t limit, int threaded) { janet_q_init(&chan->items); janet_q_init(&chan->read_pending); janet_q_init(&chan->write_pending); - janet_os_mutex_init(&chan->lock); + janet_os_mutex_init((JanetOSMutex *) &chan->lock); } static void janet_chan_deinit(JanetChannel *chan) { @@ -656,17 +665,17 @@ static void janet_chan_deinit(JanetChannel *chan) { } } janet_q_deinit(&chan->items); - janet_os_mutex_deinit(&chan->lock); + 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(&chan->lock); + janet_os_mutex_lock((JanetOSMutex *) &chan->lock); } static void janet_chan_unlock(JanetChannel *chan) { if (!janet_chan_is_threaded(chan)) return; - janet_os_mutex_unlock(&chan->lock); + janet_os_mutex_unlock((JanetOSMutex *) &chan->lock); } /* @@ -2715,6 +2724,8 @@ JANET_CORE_FN(cfun_ev_go, return janet_wrap_fiber(fiber); } +#define JANET_THREAD_SUPERVISOR_FLAG 0x100 + /* For ev/thread - Run an interpreter in the new thread. */ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) { JanetBuffer *buffer = (JanetBuffer *) args.argp; @@ -2737,7 +2748,7 @@ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) { } /* Get supervsior */ - if (flags & 0x8) { + if (flags & JANET_THREAD_SUPERVISOR_FLAG) { Janet sup = janet_unmarshal(nextbytes, endbytes - nextbytes, JANET_MARSHAL_UNSAFE, NULL, &nextbytes); @@ -2789,6 +2800,10 @@ static JanetEVGenericMessage janet_go_thread_subr(JanetEVGenericMessage args) { } else { fiber = janet_unwrap_fiber(fiberv); } + if (flags & 0x8) { + if (NULL == fiber->env) fiber->env = janet_table(0); + janet_table_put(fiber->env, janet_ckeywordv("task-id"), value); + } fiber->supervisor_channel = janet_vm.user; janet_schedule(fiber, value); janet_loop(); @@ -2833,6 +2848,7 @@ JANET_CORE_FN(cfun_ev_thread, "If you want to run the thread without waiting for a result, pass the `:n` flag to return nil immediately. " "Otherwise, returns nil. Available flags:\n\n" "* `:n` - return immediately\n" + "* `:t` - set the task-id of the new thread to value. The task-id is passed in messages to the supervisor channel.\n" "* `:a` - don't copy abstract registry to new thread (performance optimization)\n" "* `:c` - don't copy cfunction registry to new thread (performance optimization)") { janet_arity(argc, 1, 4); @@ -2840,10 +2856,10 @@ JANET_CORE_FN(cfun_ev_thread, if (!janet_checktype(argv[0], JANET_FUNCTION)) janet_getfiber(argv, 0); uint64_t flags = 0; if (argc >= 3) { - flags = janet_getflags(argv, 2, "nac"); + flags = janet_getflags(argv, 2, "nact"); } void *supervisor = janet_optabstract(argv, argc, 3, &janet_channel_type, janet_vm.root_fiber->supervisor_channel); - if (NULL != supervisor) flags |= 0x8; + if (NULL != supervisor) flags |= JANET_THREAD_SUPERVISOR_FLAG; /* Marshal arguments for the new thread. */ JanetBuffer *buffer = janet_malloc(sizeof(JanetBuffer)); @@ -2854,7 +2870,7 @@ JANET_CORE_FN(cfun_ev_thread, if (!(flags & 0x2)) { janet_marshal(buffer, janet_wrap_table(janet_vm.abstract_registry), NULL, JANET_MARSHAL_UNSAFE); } - if (flags & 0x8) { + if (flags & JANET_THREAD_SUPERVISOR_FLAG) { janet_marshal(buffer, janet_wrap_abstract(supervisor), NULL, JANET_MARSHAL_UNSAFE); } if (!(flags & 0x4)) { @@ -3013,6 +3029,106 @@ JANET_CORE_FN(janet_cfun_stream_write, janet_await(); } +static int mutexgc(void *p, size_t size) { + (void) size; + janet_os_mutex_deinit(p); + return 0; +} + +const JanetAbstractType janet_mutex_type = { + "core/lock", + mutexgc, + JANET_ATEND_GC +}; + +JANET_CORE_FN(janet_cfun_mutex, + "(ev/lock)", + "Create a new lock to coordinate threads.") { + janet_fixarity(argc, 0); + (void) argv; + void *mutex = janet_abstract_threaded(&janet_mutex_type, janet_os_mutex_size()); + janet_os_mutex_init(mutex); + return janet_wrap_abstract(mutex); +} + +JANET_CORE_FN(janet_cfun_mutex_acquire, + "(ev/acquire-lock lock)", + "Acquire a lock such that this operating system thread is the only thread with access to this resource." + " This will block this entire thread until the lock becomes available, and will not yield to other fibers " + "on this system thread.") { + janet_fixarity(argc, 1); + void *mutex = janet_getabstract(argv, 0, &janet_mutex_type); + janet_os_mutex_lock(mutex); + return argv[0]; +} + +JANET_CORE_FN(janet_cfun_mutex_release, + "(ev/release-lock lock)", + "Release a lock such that other threads may acquire it.") { + janet_fixarity(argc, 1); + void *mutex = janet_getabstract(argv, 0, &janet_mutex_type); + janet_os_mutex_unlock(mutex); + return argv[0]; +} + +static int rwlockgc(void *p, size_t size) { + (void) size; + janet_os_rwlock_deinit(p); + return 0; +} + +const JanetAbstractType janet_rwlock_type = { + "core/rwlock", + rwlockgc, + JANET_ATEND_GC +}; + +JANET_CORE_FN(janet_cfun_rwlock, + "(ev/rwlock)", + "Create a new read-write lock to coordinate threads.") { + janet_fixarity(argc, 0); + (void) argv; + void *rwlock = janet_abstract_threaded(&janet_rwlock_type, janet_os_rwlock_size()); + janet_os_rwlock_init(rwlock); + return janet_wrap_abstract(rwlock); +} + +JANET_CORE_FN(janet_cfun_rwlock_read_lock, + "(ev/acquire-rlock rwlock)", + "Acquire a read lock an a read-write lock.") { + janet_fixarity(argc, 1); + void *rwlock = janet_getabstract(argv, 0, &janet_rwlock_type); + janet_os_rwlock_rlock(rwlock); + return argv[0]; +} + +JANET_CORE_FN(janet_cfun_rwlock_write_lock, + "(ev/acquire-wlock rwlock)", + "Acquire a write lock on a read-write lock.") { + janet_fixarity(argc, 1); + void *rwlock = janet_getabstract(argv, 0, &janet_rwlock_type); + janet_os_rwlock_wlock(rwlock); + return argv[0]; +} + +JANET_CORE_FN(janet_cfun_rwlock_read_release, + "(ev/release-rlock rwlock)", + "Release a read lock on a read-write lock") { + janet_fixarity(argc, 1); + void *rwlock = janet_getabstract(argv, 0, &janet_rwlock_type); + janet_os_rwlock_runlock(rwlock); + return argv[0]; +} + +JANET_CORE_FN(janet_cfun_rwlock_write_release, + "(ev/release-wlock rwlock)", + "Release a write lock on a read-write lock") { + janet_fixarity(argc, 1); + void *rwlock = janet_getabstract(argv, 0, &janet_rwlock_type); + janet_os_rwlock_wunlock(rwlock); + return argv[0]; +} + void janet_lib_ev(JanetTable *env) { JanetRegExt ev_cfuns_ext[] = { JANET_CORE_REG("ev/give", cfun_channel_push), @@ -3035,12 +3151,22 @@ void janet_lib_ev(JanetTable *env) { JANET_CORE_REG("ev/read", janet_cfun_stream_read), JANET_CORE_REG("ev/chunk", janet_cfun_stream_chunk), JANET_CORE_REG("ev/write", janet_cfun_stream_write), + JANET_CORE_REG("ev/lock", janet_cfun_mutex), + JANET_CORE_REG("ev/acquire-lock", janet_cfun_mutex_acquire), + JANET_CORE_REG("ev/release-lock", janet_cfun_mutex_release), + JANET_CORE_REG("ev/rwlock", janet_cfun_rwlock), + JANET_CORE_REG("ev/acquire-rlock", janet_cfun_rwlock_read_lock), + JANET_CORE_REG("ev/acquire-wlock", janet_cfun_rwlock_write_lock), + JANET_CORE_REG("ev/release-rlock", janet_cfun_rwlock_read_release), + JANET_CORE_REG("ev/release-wlock", janet_cfun_rwlock_write_release), JANET_REG_END }; janet_core_cfuns_ext(env, NULL, ev_cfuns_ext); janet_register_abstract_type(&janet_stream_type); janet_register_abstract_type(&janet_channel_type); + janet_register_abstract_type(&janet_mutex_type); + janet_register_abstract_type(&janet_rwlock_type); } #endif diff --git a/src/core/features.h b/src/core/features.h index 6f37f34c..ce5e3bf1 100644 --- a/src/core/features.h +++ b/src/core/features.h @@ -36,13 +36,22 @@ # endif #endif +/* Needed for sched.h for cpu count */ +#ifdef __linux__ +#define _GNU_SOURCE +#endif + #if defined(WIN32) || defined(_WIN32) #define WIN32_LEAN_AND_MEAN #endif -/* Needed for realpath on linux */ -#if !defined(_XOPEN_SOURCE) && (defined(__linux__) || defined(__EMSCRIPTEN__)) -#define _XOPEN_SOURCE 500 +/* Needed for realpath on linux, as well as pthread rwlocks. */ +#ifndef _XOPEN_SOURCE +#define _XOPEN_SOURCE 600 +#endif +#if _XOPEN_SOURCE < 600 +#undef _XOPEN_SOURCE +#define _XOPEN_SOURCE 600 #endif /* Needed for timegm and other extensions when building with -std=c99. diff --git a/src/core/ffi.c b/src/core/ffi.c new file mode 100644 index 00000000..60f7e9dc --- /dev/null +++ b/src/core/ffi.c @@ -0,0 +1,1241 @@ +/* +* Copyright (c) 2022 Calvin Rose +* +* Permission is hereby granted, free of charge, to any person obtaining a copy +* of this software and associated documentation files (the "Software"), to +* deal in the Software without restriction, including without limitation the +* rights to use, copy, modify, merge, publish, distribute, sublicense, and/or +* sell copies of the Software, and to permit persons to whom the Software is +* furnished to do so, subject to the following conditions: +* +* The above copyright notice and this permission notice shall be included in +* all copies or substantial portions of the Software. +* +* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS +* IN THE SOFTWARE. +*/ + +#ifndef JANET_AMALG +#include "features.h" +#include +#include "util.h" +#endif + +#ifdef JANET_FFI + +#ifdef _MSC_VER +#define alloca _alloca +#elif defined(JANET_LINUX) +#include +#elif !defined(alloca) +/* Last ditch effort to get alloca - works for gcc and clang */ +#define alloca __builtin_alloca +#endif + +#define JANET_FFI_MAX_RECUR 64 + +/* Compiler, OS, and arch detection. Used + * to enable a set of calling conventions. The + * :none calling convention is always enabled. */ +#if defined(JANET_WINDOWS) && (defined(__x86_64__) || defined(_M_X64)) +#define JANET_FFI_WIN64_ENABLED +#endif +#if (defined(__x86_64__) || defined(_M_X64)) && !defined(JANET_WINDOWS) +#define JANET_FFI_SYSV64_ENABLED +#endif + +typedef struct JanetFFIType JanetFFIType; +typedef struct JanetFFIStruct JanetFFIStruct; + +typedef enum { + JANET_FFI_TYPE_VOID, + JANET_FFI_TYPE_BOOL, + JANET_FFI_TYPE_PTR, + JANET_FFI_TYPE_STRING, + JANET_FFI_TYPE_FLOAT, + JANET_FFI_TYPE_DOUBLE, + JANET_FFI_TYPE_INT8, + JANET_FFI_TYPE_UINT8, + JANET_FFI_TYPE_INT16, + JANET_FFI_TYPE_UINT16, + JANET_FFI_TYPE_INT32, + JANET_FFI_TYPE_UINT32, + JANET_FFI_TYPE_INT64, + JANET_FFI_TYPE_UINT64, + JANET_FFI_TYPE_STRUCT +} JanetFFIPrimType; + +/* Custom alignof since alignof not in c99 standard */ +#define ALIGNOF(type) offsetof(struct { char c; type member; }, member) + +typedef struct { + size_t size; + size_t align; +} JanetFFIPrimInfo; + +static const JanetFFIPrimInfo janet_ffi_type_info[] = { + {0, 0}, /* JANET_FFI_TYPE_VOID */ + {sizeof(char), ALIGNOF(char)}, /* JANET_FFI_TYPE_BOOL */ + {sizeof(void *), ALIGNOF(void *)}, /* JANET_FFI_TYPE_PTR */ + {sizeof(char *), ALIGNOF(char *)}, /* JANET_FFI_TYPE_STRING */ + {sizeof(float), ALIGNOF(float)}, /* JANET_FFI_TYPE_FLOAT */ + {sizeof(double), ALIGNOF(double)}, /* JANET_FFI_TYPE_DOUBLE */ + {sizeof(int8_t), ALIGNOF(int8_t)}, /* JANET_FFI_TYPE_INT8 */ + {sizeof(uint8_t), ALIGNOF(uint8_t)}, /* JANET_FFI_TYPE_UINT8 */ + {sizeof(int16_t), ALIGNOF(int16_t)}, /* JANET_FFI_TYPE_INT16 */ + {sizeof(uint16_t), ALIGNOF(uint16_t)}, /* JANET_FFI_TYPE_UINT16 */ + {sizeof(int32_t), ALIGNOF(int32_t)}, /* JANET_FFI_TYPE_INT32 */ + {sizeof(uint32_t), ALIGNOF(uint32_t)}, /* JANET_FFI_TYPE_UINT32 */ + {sizeof(int64_t), ALIGNOF(int64_t)}, /* JANET_FFI_TYPE_INT64 */ + {sizeof(uint64_t), ALIGNOF(uint64_t)}, /* JANET_FFI_TYPE_UINT64 */ + {0, ALIGNOF(uint64_t)} /* JANET_FFI_TYPE_STRUCT */ +}; + +struct JanetFFIType { + JanetFFIStruct *st; + JanetFFIPrimType prim; + int32_t array_count; +}; + +typedef struct { + JanetFFIType type; + size_t offset; +} JanetFFIStructMember; + +/* Also used to store array types */ +struct JanetFFIStruct { + uint32_t size; + uint32_t align; + uint32_t field_count; + uint32_t is_aligned; + JanetFFIStructMember fields[]; +}; + +/* Specifies how the registers are classified. This is used + * to determine if a certain argument should be passed in a register, + * on the stack, special floating pointer register, etc. */ +typedef enum { + JANET_SYSV64_INTEGER, + JANET_SYSV64_SSE, + JANET_SYSV64_SSEUP, + JANET_SYSV64_X87, + JANET_SYSV64_X87UP, + JANET_SYSV64_COMPLEX_X87, + JANET_SYSV64_NO_CLASS, + JANET_SYSV64_MEMORY, + JANET_WIN64_REGISTER, + JANET_WIN64_STACK, + JANET_WIN64_REGISTER_REF, + JANET_WIN64_STACK_REF +} JanetFFIWordSpec; + +/* Describe how each Janet argument is interpreted in terms of machine words + * that will be mapped to registers/stack. */ +typedef struct { + JanetFFIType type; + JanetFFIWordSpec spec; + uint32_t offset; /* point to the exact register / stack offset depending on spec. */ + uint32_t offset2; /* for reference passing apis (windows), use to allocate reference */ +} JanetFFIMapping; + +typedef enum { + JANET_FFI_CC_NONE, + JANET_FFI_CC_SYSV_64, + JANET_FFI_CC_WIN_64 +} JanetFFICallingConvention; + +#ifdef JANET_FFI_WIN64_ENABLED +#define JANET_FFI_CC_DEFAULT JANET_FFI_CC_WIN_64 +#elif defined(JANET_FFI_SYSV64_ENABLED) +#define JANET_FFI_CC_DEFAULT JANET_FFI_CC_SYSV_64 +#else +#define JANET_FFI_CC_DEFAULT JANET_FFI_CC_NONE +#endif + +#define JANET_FFI_MAX_ARGS 32 + +typedef struct { + uint32_t frame_size; + uint32_t arg_count; + uint32_t word_count; + uint32_t variant; + uint32_t stack_count; + JanetFFICallingConvention cc; + JanetFFIMapping ret; + JanetFFIMapping args[JANET_FFI_MAX_ARGS]; +} JanetFFISignature; + +int signature_mark(void *p, size_t s) { + (void) s; + JanetFFISignature *sig = p; + for (uint32_t i = 0; i < sig->arg_count; i++) { + JanetFFIType t = sig->args[i].type; + if (t.prim == JANET_FFI_TYPE_STRUCT) { + janet_mark(janet_wrap_abstract(t.st)); + } + } + return 0; +} + +static const JanetAbstractType janet_signature_type = { + "core/ffi-signature", + NULL, + signature_mark, + JANET_ATEND_GCMARK +}; + +int struct_mark(void *p, size_t s) { + (void) s; + JanetFFIStruct *st = p; + for (uint32_t i = 0; i < st->field_count; i++) { + JanetFFIType t = st->fields[i].type; + if (t.prim == JANET_FFI_TYPE_STRUCT) { + janet_mark(janet_wrap_abstract(t.st)); + } + } + return 0; +} + +static const JanetAbstractType janet_struct_type = { + "core/ffi-struct", + NULL, + struct_mark, + JANET_ATEND_GCMARK +}; + +typedef struct { + Clib clib; + int closed; + int is_self; +} JanetAbstractNative; + +static const JanetAbstractType janet_native_type = { + "core/ffi-native", + JANET_ATEND_NAME +}; + +static JanetFFIType prim_type(JanetFFIPrimType pt) { + JanetFFIType t; + t.prim = pt; + t.st = NULL; + t.array_count = -1; + return t; +} + +static size_t type_size(JanetFFIType t) { + size_t count = t.array_count < 0 ? 1 : (size_t) t.array_count; + if (t.prim == JANET_FFI_TYPE_STRUCT) { + return t.st->size * count; + } else { + return janet_ffi_type_info[t.prim].size * count; + } +} + +static size_t type_align(JanetFFIType t) { + if (t.prim == JANET_FFI_TYPE_STRUCT) { + return t.st->align; + } else { + return janet_ffi_type_info[t.prim].align; + } +} + +static JanetFFICallingConvention decode_ffi_cc(const uint8_t *name) { + if (!janet_cstrcmp(name, "none")) return JANET_FFI_CC_NONE; +#ifdef JANET_FFI_WIN64_ENABLED + if (!janet_cstrcmp(name, "win64")) return JANET_FFI_CC_WIN_64; +#endif +#ifdef JANET_FFI_SYSV64_ENABLED + if (!janet_cstrcmp(name, "sysv64")) return JANET_FFI_CC_SYSV_64; +#endif + if (!janet_cstrcmp(name, "default")) return JANET_FFI_CC_DEFAULT; + janet_panicf("unknown calling convention %s", name); +} + +static JanetFFIPrimType decode_ffi_prim(const uint8_t *name) { + if (!janet_cstrcmp(name, "void")) return JANET_FFI_TYPE_VOID; + if (!janet_cstrcmp(name, "bool")) return JANET_FFI_TYPE_BOOL; + if (!janet_cstrcmp(name, "ptr")) return JANET_FFI_TYPE_PTR; + if (!janet_cstrcmp(name, "string")) return JANET_FFI_TYPE_STRING; + if (!janet_cstrcmp(name, "float")) return JANET_FFI_TYPE_FLOAT; + if (!janet_cstrcmp(name, "double")) return JANET_FFI_TYPE_DOUBLE; + if (!janet_cstrcmp(name, "int8")) return JANET_FFI_TYPE_INT8; + if (!janet_cstrcmp(name, "uint8")) return JANET_FFI_TYPE_UINT8; + if (!janet_cstrcmp(name, "int16")) return JANET_FFI_TYPE_INT16; + if (!janet_cstrcmp(name, "uint16")) return JANET_FFI_TYPE_UINT16; + if (!janet_cstrcmp(name, "int32")) return JANET_FFI_TYPE_INT32; + if (!janet_cstrcmp(name, "uint32")) return JANET_FFI_TYPE_UINT32; + if (!janet_cstrcmp(name, "int64")) return JANET_FFI_TYPE_INT64; + if (!janet_cstrcmp(name, "uint64")) return JANET_FFI_TYPE_UINT64; +#ifdef JANET_64 + if (!janet_cstrcmp(name, "size")) return JANET_FFI_TYPE_UINT64; + if (!janet_cstrcmp(name, "ssize")) return JANET_FFI_TYPE_INT64; +#else + if (!janet_cstrcmp(name, "size")) return JANET_FFI_TYPE_UINT32; + if (!janet_cstrcmp(name, "ssize")) return JANET_FFI_TYPE_INT32; +#endif + /* aliases */ + if (!janet_cstrcmp(name, "r32")) return JANET_FFI_TYPE_FLOAT; + if (!janet_cstrcmp(name, "r64")) return JANET_FFI_TYPE_DOUBLE; + if (!janet_cstrcmp(name, "s8")) return JANET_FFI_TYPE_INT8; + if (!janet_cstrcmp(name, "u8")) return JANET_FFI_TYPE_UINT8; + if (!janet_cstrcmp(name, "s16")) return JANET_FFI_TYPE_INT16; + if (!janet_cstrcmp(name, "u16")) return JANET_FFI_TYPE_UINT16; + if (!janet_cstrcmp(name, "s32")) return JANET_FFI_TYPE_INT32; + if (!janet_cstrcmp(name, "u32")) return JANET_FFI_TYPE_UINT32; + if (!janet_cstrcmp(name, "s64")) return JANET_FFI_TYPE_INT64; + if (!janet_cstrcmp(name, "u64")) return JANET_FFI_TYPE_UINT64; + if (!janet_cstrcmp(name, "char")) return JANET_FFI_TYPE_INT8; + if (!janet_cstrcmp(name, "short")) return JANET_FFI_TYPE_INT16; + if (!janet_cstrcmp(name, "int")) return JANET_FFI_TYPE_INT32; + if (!janet_cstrcmp(name, "long")) return JANET_FFI_TYPE_INT64; + if (!janet_cstrcmp(name, "byte")) return JANET_FFI_TYPE_UINT8; + if (!janet_cstrcmp(name, "uchar")) return JANET_FFI_TYPE_UINT8; + if (!janet_cstrcmp(name, "ushort")) return JANET_FFI_TYPE_UINT16; + if (!janet_cstrcmp(name, "uint")) return JANET_FFI_TYPE_UINT32; + if (!janet_cstrcmp(name, "ulong")) return JANET_FFI_TYPE_UINT64; + janet_panicf("unknown machine type %s", name); +} + +/* A common callback function signature. To avoid runtime code generation, which is prohibited + * on many platforms, often buggy (see libffi), and generally complicated, instead provide + * a single (or small set of commonly used function signatures). All callbacks should + * eventually call this. */ +void janet_ffi_trampoline(void *ctx, void *userdata) { + if (NULL == userdata) { + /* Userdata not set. */ + janet_eprintf("no userdata found for janet callback"); + return; + } + Janet context = janet_wrap_pointer(ctx); + JanetFunction *fun = userdata; + janet_call(fun, 1, &context); +} + +static JanetFFIType decode_ffi_type(Janet x); + +static JanetFFIStruct *build_struct_type(int32_t argc, const Janet *argv) { + /* Use :pack to indicate a single packed struct member and :pack-all + * to pack the remaining members */ + int32_t member_count = argc; + int all_packed = 0; + for (int32_t i = 0; i < argc; i++) { + if (janet_keyeq(argv[i], "pack")) { + member_count--; + } else if (janet_keyeq(argv[i], "pack-all")) { + member_count--; + all_packed = 1; + } + } + + JanetFFIStruct *st = janet_abstract(&janet_struct_type, + sizeof(JanetFFIStruct) + argc * sizeof(JanetFFIStructMember)); + st->field_count = member_count; + st->size = 0; + st->align = 1; + if (argc == 0) { + janet_panic("invalid empty struct"); + } + uint32_t is_aligned = 1; + int32_t i = 0; + for (int32_t j = 0; j < argc; j++) { + int pack_one = 0; + if (janet_keyeq(argv[j], "pack") || janet_keyeq(argv[j], "pack-all")) { + pack_one = 1; + j++; + if (j == argc) break; + } + st->fields[i].type = decode_ffi_type(argv[j]); + size_t el_size = type_size(st->fields[i].type); + size_t el_align = type_align(st->fields[i].type); + if (all_packed || pack_one) { + if (st->size % el_align != 0) is_aligned = 0; + st->fields[i].offset = st->size; + st->size += el_size; + } else { + if (el_align > st->align) st->align = el_align; + st->fields[i].offset = (((st->size + el_align - 1) / el_align) * el_align); + st->size = el_size + st->fields[i].offset; + } + i++; + } + st->is_aligned = is_aligned; + st->size += (st->align - 1); + st->size /= st->align; + st->size *= st->align; + return st; +} + +static JanetFFIType decode_ffi_type(Janet x) { + if (janet_checktype(x, JANET_KEYWORD)) { + return prim_type(decode_ffi_prim(janet_unwrap_keyword(x))); + } + JanetFFIType ret; + ret.array_count = -1; + ret.prim = JANET_FFI_TYPE_STRUCT; + if (janet_checkabstract(x, &janet_struct_type)) { + ret.st = janet_unwrap_abstract(x); + return ret; + } + int32_t len; + const Janet *els; + if (janet_indexed_view(x, &els, &len)) { + if (janet_checktype(x, JANET_ARRAY)) { + if (len != 2 && len != 1) janet_panicf("array type must be of form @[type count], got %v", x); + ret = decode_ffi_type(els[0]); + int32_t array_count = len == 1 ? 0 : janet_getnat(els, 1); + ret.array_count = array_count; + } else { + ret.st = build_struct_type(len, els); + } + return ret; + } else { + janet_panicf("bad native type %v", x); + } +} + +JANET_CORE_FN(cfun_ffi_struct, + "(ffi/struct & types)", + "Create a struct type definition that can be used to pass structs into native functions. ") { + janet_arity(argc, 1, -1); + return janet_wrap_abstract(build_struct_type(argc, argv)); +} + +JANET_CORE_FN(cfun_ffi_size, + "(ffi/size type)", + "Get the size of an ffi type in bytes.") { + janet_fixarity(argc, 1); + size_t size = type_size(decode_ffi_type(argv[0])); + return janet_wrap_number((double) size); +} + +JANET_CORE_FN(cfun_ffi_align, + "(ffi/align type)", + "Get the align of an ffi type in bytes.") { + janet_fixarity(argc, 1); + size_t size = type_align(decode_ffi_type(argv[0])); + return janet_wrap_number((double) size); +} + +static void *janet_ffi_getpointer(const Janet *argv, int32_t n) { + switch (janet_type(argv[n])) { + default: + janet_panicf("bad slot #%d, expected ffi pointer convertable type, got %v", argv[n]); + case JANET_POINTER: + case JANET_STRING: + case JANET_KEYWORD: + case JANET_SYMBOL: + case JANET_ABSTRACT: + return janet_unwrap_pointer(argv[n]); + case JANET_BUFFER: + return janet_unwrap_buffer(argv[n])->data; + case JANET_FUNCTION: + /* Users may pass in a function. Any function passed is almost certainly + * being used as a callback, so we add it to the root set. */ + janet_gcroot(argv[n]); + return janet_unwrap_pointer(argv[n]); + case JANET_NIL: + return NULL; + } +} + +/* Write a value given by some Janet values and an FFI type as it would appear in memory. + * The alignment and space available is assumed to already be sufficient */ +static void janet_ffi_write_one(void *to, const Janet *argv, int32_t n, JanetFFIType type, int recur) { + if (recur == 0) janet_panic("recursion too deep"); + if (type.array_count >= 0) { + JanetFFIType el_type = type; + el_type.array_count = -1; + size_t el_size = type_size(el_type); + JanetView els = janet_getindexed(argv, n); + if (els.len != type.array_count) { + janet_panicf("bad array length, expected %d, got %d", type.array_count, els.len); + } + char *cursor = to; + for (int32_t i = 0; i < els.len; i++) { + janet_ffi_write_one(cursor, els.items, i, el_type, recur - 1); + cursor += el_size; + } + return; + } + switch (type.prim) { + case JANET_FFI_TYPE_VOID: + if (!janet_checktype(argv[n], JANET_NIL)) { + janet_panicf("expected nil, got %v", argv[n]); + } + break; + case JANET_FFI_TYPE_STRUCT: { + JanetView els = janet_getindexed(argv, n); + JanetFFIStruct *st = type.st; + if ((uint32_t) els.len != st->field_count) { + janet_panicf("wrong number of fields in struct, expected %d, got %d", + (int32_t) st->field_count, els.len); + } + for (int32_t i = 0; i < els.len; i++) { + JanetFFIType tp = st->fields[i].type; + janet_ffi_write_one(to + st->fields[i].offset, els.items, i, tp, recur - 1); + } + } + break; + case JANET_FFI_TYPE_DOUBLE: + ((double *)(to))[0] = janet_getnumber(argv, n); + break; + case JANET_FFI_TYPE_FLOAT: + ((float *)(to))[0] = janet_getnumber(argv, n); + break; + case JANET_FFI_TYPE_PTR: + ((void **)(to))[0] = janet_ffi_getpointer(argv, n); + break; + case JANET_FFI_TYPE_STRING: + ((const char **)(to))[0] = janet_getcstring(argv, n); + break; + case JANET_FFI_TYPE_BOOL: + ((bool *)(to))[0] = janet_getboolean(argv, n); + break; + case JANET_FFI_TYPE_INT8: + ((int8_t *)(to))[0] = janet_getinteger(argv, n); + break; + case JANET_FFI_TYPE_INT16: + ((int16_t *)(to))[0] = janet_getinteger(argv, n); + break; + case JANET_FFI_TYPE_INT32: + ((int32_t *)(to))[0] = janet_getinteger(argv, n); + break; + case JANET_FFI_TYPE_INT64: + ((int64_t *)(to))[0] = janet_getinteger64(argv, n); + break; + case JANET_FFI_TYPE_UINT8: + ((uint8_t *)(to))[0] = janet_getuinteger64(argv, n); + break; + case JANET_FFI_TYPE_UINT16: + ((uint16_t *)(to))[0] = janet_getuinteger64(argv, n); + break; + case JANET_FFI_TYPE_UINT32: + ((uint32_t *)(to))[0] = janet_getuinteger64(argv, n); + break; + case JANET_FFI_TYPE_UINT64: + ((uint64_t *)(to))[0] = janet_getuinteger64(argv, n); + break; + } +} + +/* Read a value from memory and construct a Janet data structure that can be passed back into + * the interpreter. This should be the inverse to janet_ffi_write_one. It is assumed that the + * size of the data is correct. */ +static Janet janet_ffi_read_one(const uint8_t *from, JanetFFIType type, int recur) { + if (recur == 0) janet_panic("recursion too deep"); + if (type.array_count >= 0) { + JanetFFIType el_type = type; + el_type.array_count = -1; + size_t el_size = type_size(el_type); + JanetArray *array = janet_array(type.array_count); + for (int32_t i = 0; i < type.array_count; i++) { + janet_array_push(array, janet_ffi_read_one(from, el_type, recur - 1)); + from += el_size; + } + return janet_wrap_array(array); + } + switch (type.prim) { + default: + case JANET_FFI_TYPE_VOID: + return janet_wrap_nil(); + case JANET_FFI_TYPE_STRUCT: { + JanetFFIStruct *st = type.st; + Janet *tup = janet_tuple_begin(st->field_count); + for (uint32_t i = 0; i < st->field_count; i++) { + JanetFFIType tp = st->fields[i].type; + tup[i] = janet_ffi_read_one(from + st->fields[i].offset, tp, recur - 1); + } + return janet_wrap_tuple(janet_tuple_end(tup)); + } + case JANET_FFI_TYPE_DOUBLE: + return janet_wrap_number(((double *)(from))[0]); + case JANET_FFI_TYPE_FLOAT: + return janet_wrap_number(((float *)(from))[0]); + case JANET_FFI_TYPE_PTR: { + void *ptr = ((void **)(from))[0]; + return (NULL == ptr) ? janet_wrap_nil() : janet_wrap_pointer(ptr); + } + case JANET_FFI_TYPE_STRING: + return janet_cstringv(((char **)(from))[0]); + case JANET_FFI_TYPE_BOOL: + return janet_wrap_boolean(((bool *)(from))[0]); + case JANET_FFI_TYPE_INT8: + return janet_wrap_number(((int8_t *)(from))[0]); + case JANET_FFI_TYPE_INT16: + return janet_wrap_number(((int16_t *)(from))[0]); + case JANET_FFI_TYPE_INT32: + return janet_wrap_number(((int32_t *)(from))[0]); + case JANET_FFI_TYPE_UINT8: + return janet_wrap_number(((uint8_t *)(from))[0]); + case JANET_FFI_TYPE_UINT16: + return janet_wrap_number(((uint16_t *)(from))[0]); + case JANET_FFI_TYPE_UINT32: + return janet_wrap_number(((uint32_t *)(from))[0]); +#ifdef JANET_INT_TYPES + case JANET_FFI_TYPE_INT64: + return janet_wrap_s64(((int64_t *)(from))[0]); + case JANET_FFI_TYPE_UINT64: + return janet_wrap_u64(((uint64_t *)(from))[0]); +#else + case JANET_FFI_TYPE_INT64: + return janet_wrap_number(((int64_t *)(from))[0]); + case JANET_FFI_TYPE_UINT64: + return janet_wrap_number(((uint64_t *)(from))[0]); +#endif + } +} + +static JanetFFIMapping void_mapping(void) { + JanetFFIMapping m; + m.type = prim_type(JANET_FFI_TYPE_VOID); + m.spec = JANET_SYSV64_NO_CLASS; + m.offset = 0; + return m; +} + +#ifdef JANET_FFI_SYSV64_ENABLED +/* AMD64 ABI Draft 0.99.7 – November 17, 2014 – 15:08 + * See section 3.2.3 Parameter Passing */ +static JanetFFIWordSpec sysv64_classify(JanetFFIType type) { + switch (type.prim) { + case JANET_FFI_TYPE_PTR: + case JANET_FFI_TYPE_STRING: + case JANET_FFI_TYPE_BOOL: + case JANET_FFI_TYPE_INT8: + case JANET_FFI_TYPE_INT16: + case JANET_FFI_TYPE_INT32: + case JANET_FFI_TYPE_INT64: + case JANET_FFI_TYPE_UINT8: + case JANET_FFI_TYPE_UINT16: + case JANET_FFI_TYPE_UINT32: + case JANET_FFI_TYPE_UINT64: + return JANET_SYSV64_INTEGER; + case JANET_FFI_TYPE_DOUBLE: + case JANET_FFI_TYPE_FLOAT: + return JANET_SYSV64_SSE; + case JANET_FFI_TYPE_STRUCT: { + JanetFFIStruct *st = type.st; + if (st->size > 16) return JANET_SYSV64_MEMORY; + if (!st->is_aligned) return JANET_SYSV64_MEMORY; + JanetFFIWordSpec clazz = JANET_SYSV64_NO_CLASS; + for (uint32_t i = 0; i < st->field_count; i++) { + JanetFFIWordSpec next_class = sysv64_classify(st->fields[i].type); + if (next_class != clazz) { + if (clazz == JANET_SYSV64_NO_CLASS) { + clazz = next_class; + } else if (clazz == JANET_SYSV64_MEMORY || next_class == JANET_SYSV64_MEMORY) { + clazz = JANET_SYSV64_MEMORY; + } else if (clazz == JANET_SYSV64_INTEGER || next_class == JANET_SYSV64_INTEGER) { + clazz = JANET_SYSV64_INTEGER; + } else if (next_class == JANET_SYSV64_X87 || next_class == JANET_SYSV64_X87UP + || next_class == JANET_SYSV64_COMPLEX_X87) { + clazz = JANET_SYSV64_MEMORY; + } else { + clazz = JANET_SYSV64_SSE; + } + } + } + return clazz; + } + case JANET_FFI_TYPE_VOID: + return JANET_SYSV64_NO_CLASS; + default: + janet_panic("nyi"); + return JANET_SYSV64_NO_CLASS; + } +} +#endif + +JANET_CORE_FN(cfun_ffi_signature, + "(ffi/signature calling-convention ret-type & arg-types)", + "Create a function signature object that can be used to make calls " + "with raw function pointers.") { + janet_arity(argc, 2, -1); + uint32_t frame_size = 0; + uint32_t variant = 0; + uint32_t arg_count = argc - 2; + uint32_t stack_count = 0; + JanetFFICallingConvention cc = decode_ffi_cc(janet_getkeyword(argv, 0)); + JanetFFIType ret_type = decode_ffi_type(argv[1]); + JanetFFIMapping ret = { + ret_type, + JANET_SYSV64_NO_CLASS, + 0, + 0 + }; + JanetFFIMapping mappings[JANET_FFI_MAX_ARGS]; + for (int i = 0; i < JANET_FFI_MAX_ARGS; i++) mappings[i] = void_mapping(); + switch (cc) { + default: + case JANET_FFI_CC_NONE: { + /* Even if unsupported, we can check that the signature is valid + * and error at runtime */ + for (uint32_t i = 0; i < arg_count; i++) { + decode_ffi_type(argv[i + 2]); + } + } + break; + +#ifdef JANET_FFI_WIN64_ENABLED + case JANET_FFI_CC_WIN_64: { + size_t ret_size = type_size(ret.type); + size_t ref_stack_count = 0; + ret.spec = JANET_WIN64_REGISTER; + uint32_t next_register = 0; + if (ret_size != 1 && ret_size != 2 && ret_size != 4 && ret_size != 8) { + ret.spec = JANET_WIN64_REGISTER_REF; + next_register++; + } else if (ret.type.prim == JANET_FFI_TYPE_FLOAT || + ret.type.prim == JANET_FFI_TYPE_DOUBLE) { + variant += 16; + } + for (uint32_t i = 0; i < arg_count; i++) { + mappings[i].type = decode_ffi_type(argv[i + 2]); + size_t el_size = type_size(mappings[i].type); + int is_register_sized = (el_size == 1 || el_size == 2 || el_size == 4 || el_size == 8); + if (next_register < 4) { + mappings[i].offset = next_register++; + if (is_register_sized) { + mappings[i].spec = JANET_WIN64_REGISTER; + + /* Select variant based on position of floating point arguments */ + if (mappings[i].type.prim == JANET_FFI_TYPE_FLOAT || + mappings[i].type.prim == JANET_FFI_TYPE_DOUBLE) { + variant += 1 << next_register; + } + } else { + mappings[i].spec = JANET_WIN64_REGISTER_REF; + mappings[i].offset2 = ref_stack_count; + ref_stack_count += (el_size + 15) / 16; + } + } else { + if (is_register_sized) { + mappings[i].spec = JANET_WIN64_STACK; + mappings[i].offset = stack_count; + stack_count++; + } else { + mappings[i].spec = JANET_WIN64_STACK_REF; + mappings[i].offset = stack_count; + stack_count++; + mappings[i].offset2 = ref_stack_count; + ref_stack_count += (el_size + 15) / 16; + } + } + } + + /* Take into account reference arguments and align to 16 bytes just in case */ + stack_count += 2 * ref_stack_count; + if (stack_count & 1) { + stack_count++; + } + + /* Invert stack + * Offsets are in units of 8-bytes */ + for (uint32_t i = 0; i < arg_count; i++) { + uint32_t old_offset = mappings[i].offset; + if (mappings[i].spec == JANET_WIN64_STACK) { + mappings[i].offset = stack_count - 1 - old_offset; + } else if (mappings[i].spec == JANET_WIN64_STACK_REF) { + mappings[i].offset = stack_count - 1 - old_offset; + } + if (mappings[i].spec == JANET_WIN64_STACK_REF || mappings[i].spec == JANET_WIN64_REGISTER_REF) { + /* Align size to 16 bytes */ + size_t size = (type_size(mappings[i].type) + 15) & ~0xFUL; + mappings[i].offset2 = stack_count - mappings[i].offset2 - (size / 8); + } + } + + } + break; +#endif + +#ifdef JANET_FFI_SYSV64_ENABLED + case JANET_FFI_CC_SYSV_64: { + JanetFFIWordSpec ret_spec = sysv64_classify(ret.type); + ret.spec = ret_spec; + if (ret_spec == JANET_SYSV64_SSE) variant = 1; + /* Spill register overflow to memory */ + uint32_t next_register = 0; + uint32_t next_fp_register = 0; + const uint32_t max_regs = 6; + const uint32_t max_fp_regs = 8; + if (ret_spec == JANET_SYSV64_MEMORY) { + /* First integer reg is pointer. */ + next_register = 1; + } + for (uint32_t i = 0; i < arg_count; i++) { + mappings[i].type = decode_ffi_type(argv[i + 2]); + mappings[i].offset = 0; + mappings[i].spec = sysv64_classify(mappings[i].type); + if (mappings[i].spec == JANET_SYSV64_NO_CLASS) { + janet_panic("unexpected void parameter"); + } + size_t el_size = (type_size(mappings[i].type) + 7) / 8; + switch (mappings[i].spec) { + default: + janet_panicf("nyi: %d", mappings[i].spec); + case JANET_SYSV64_INTEGER: { + if (next_register < max_regs) { + mappings[i].offset = next_register++; + } else { + mappings[i].spec = JANET_SYSV64_MEMORY; + mappings[i].offset = stack_count; + stack_count += el_size; + } + break; + } + case JANET_SYSV64_SSE: { + if (next_fp_register < max_fp_regs) { + mappings[i].offset = next_fp_register++; + } else { + mappings[i].spec = JANET_SYSV64_MEMORY; + mappings[i].offset = stack_count; + stack_count += el_size; + } + break; + } + case JANET_SYSV64_MEMORY: { + mappings[i].offset = stack_count; + stack_count += el_size; + } + } + } + + /* Invert stack */ + for (uint32_t i = 0; i < arg_count; i++) { + if (mappings[i].spec == JANET_SYSV64_MEMORY) { + uint32_t old_offset = mappings[i].offset; + size_t el_size = type_size(mappings[i].type); + mappings[i].offset = stack_count - ((el_size + 7) / 8) - old_offset; + } + } + } + break; +#endif + } + + /* Create signature abstract value */ + JanetFFISignature *abst = janet_abstract(&janet_signature_type, sizeof(JanetFFISignature)); + abst->frame_size = frame_size; + abst->cc = cc; + abst->ret = ret; + abst->arg_count = arg_count; + abst->variant = variant; + abst->stack_count = stack_count; + memcpy(abst->args, mappings, sizeof(JanetFFIMapping) * JANET_FFI_MAX_ARGS); + return janet_wrap_abstract(abst); +} + +#ifdef JANET_FFI_SYSV64_ENABLED + +static void janet_ffi_sysv64_standard_callback(void *ctx, void *userdata) { + janet_ffi_trampoline(ctx, userdata); +} + +/* Functions that set all argument registers. Two variants - one to read rax and rdx returns, another + * to read xmm0 and xmm1 returns. */ +typedef struct { + uint64_t x; + uint64_t y; +} sysv64_int_return; +typedef struct { + double x; + double y; +} sysv64_sse_return; +typedef sysv64_int_return janet_sysv64_variant_1(uint64_t a, uint64_t b, uint64_t c, uint64_t d, uint64_t e, uint64_t f, + double r1, double r2, double r3, double r4, double r5, double r6, double r7, double r8); +typedef sysv64_sse_return janet_sysv64_variant_2(uint64_t a, uint64_t b, uint64_t c, uint64_t d, uint64_t e, uint64_t f, + double r1, double r2, double r3, double r4, double r5, double r6, double r7, double r8); + +static Janet janet_ffi_sysv64(JanetFFISignature *signature, void *function_pointer, const Janet *argv) { + sysv64_int_return int_return; + sysv64_sse_return sse_return; + uint64_t regs[6]; + double fp_regs[8]; + JanetFFIWordSpec ret_spec = signature->ret.spec; + void *ret_mem = &int_return; + if (ret_spec == JANET_SYSV64_MEMORY) { + ret_mem = alloca(type_size(signature->ret.type)); + regs[0] = (uint64_t) ret_mem; + } else if (ret_spec == JANET_SYSV64_SSE) { + ret_mem = &sse_return; + } + uint64_t *stack = alloca(sizeof(uint64_t) * signature->stack_count); + for (uint32_t i = 0; i < signature->arg_count; i++) { + uint64_t *to; + int32_t n = i + 2; + JanetFFIMapping arg = signature->args[i]; + switch (arg.spec) { + default: + janet_panic("nyi"); + case JANET_SYSV64_INTEGER: + to = regs + arg.offset; + break; + case JANET_SYSV64_SSE: + to = (uint64_t *)(fp_regs + arg.offset); + break; + case JANET_SYSV64_MEMORY: + to = stack + arg.offset; + break; + } + janet_ffi_write_one(to, argv, n, arg.type, JANET_FFI_MAX_RECUR); + } + + if (signature->variant) { + sse_return = ((janet_sysv64_variant_2 *)(function_pointer))( + regs[0], regs[1], regs[2], regs[3], regs[4], regs[5], + fp_regs[0], fp_regs[1], fp_regs[2], fp_regs[3], + fp_regs[4], fp_regs[5], fp_regs[6], fp_regs[7]); + } else { + int_return = ((janet_sysv64_variant_1 *)(function_pointer))( + regs[0], regs[1], regs[2], regs[3], regs[4], regs[5], + fp_regs[0], fp_regs[1], fp_regs[2], fp_regs[3], + fp_regs[4], fp_regs[5], fp_regs[6], fp_regs[7]); + + } + + return janet_ffi_read_one(ret_mem, signature->ret.type, JANET_FFI_MAX_RECUR); +} + +#endif + +#ifdef JANET_FFI_WIN64_ENABLED + +static void janet_ffi_win64_standard_callback(void *ctx, void *userdata) { + janet_ffi_trampoline(ctx, userdata); +} + +/* Variants that allow setting all required registers for 64 bit windows calling convention. + * win64 calling convention has up to 4 arguments on registers, and one register for returns. + * Each register can either be an integer or floating point register, resulting in + * 2^5 = 32 variants. Unlike sysv, there are no function signatures that will fill + * all of the possible registers which is why we have so many variants. If you were using + * assembly, you could manually fill all of the registers and only have a single variant. + * And msvc does not support inline assembly on 64 bit targets, so yeah, we have this hackery. */ +typedef uint64_t (win64_variant_i_iiii)(uint64_t, uint64_t, uint64_t, uint64_t); +typedef uint64_t (win64_variant_i_iiif)(uint64_t, uint64_t, uint64_t, double); +typedef uint64_t (win64_variant_i_iifi)(uint64_t, uint64_t, double, uint64_t); +typedef uint64_t (win64_variant_i_iiff)(uint64_t, uint64_t, double, double); +typedef uint64_t (win64_variant_i_ifii)(uint64_t, double, uint64_t, uint64_t); +typedef uint64_t (win64_variant_i_ifif)(uint64_t, double, uint64_t, double); +typedef uint64_t (win64_variant_i_iffi)(uint64_t, double, double, uint64_t); +typedef uint64_t (win64_variant_i_ifff)(uint64_t, double, double, double); +typedef uint64_t (win64_variant_i_fiii)(double, uint64_t, uint64_t, uint64_t); +typedef uint64_t (win64_variant_i_fiif)(double, uint64_t, uint64_t, double); +typedef uint64_t (win64_variant_i_fifi)(double, uint64_t, double, uint64_t); +typedef uint64_t (win64_variant_i_fiff)(double, uint64_t, double, double); +typedef uint64_t (win64_variant_i_ffii)(double, double, uint64_t, uint64_t); +typedef uint64_t (win64_variant_i_ffif)(double, double, uint64_t, double); +typedef uint64_t (win64_variant_i_fffi)(double, double, double, uint64_t); +typedef uint64_t (win64_variant_i_ffff)(double, double, double, double); +typedef double (win64_variant_f_iiii)(uint64_t, uint64_t, uint64_t, uint64_t); +typedef double (win64_variant_f_iiif)(uint64_t, uint64_t, uint64_t, double); +typedef double (win64_variant_f_iifi)(uint64_t, uint64_t, double, uint64_t); +typedef double (win64_variant_f_iiff)(uint64_t, uint64_t, double, double); +typedef double (win64_variant_f_ifii)(uint64_t, double, uint64_t, uint64_t); +typedef double (win64_variant_f_ifif)(uint64_t, double, uint64_t, double); +typedef double (win64_variant_f_iffi)(uint64_t, double, double, uint64_t); +typedef double (win64_variant_f_ifff)(uint64_t, double, double, double); +typedef double (win64_variant_f_fiii)(double, uint64_t, uint64_t, uint64_t); +typedef double (win64_variant_f_fiif)(double, uint64_t, uint64_t, double); +typedef double (win64_variant_f_fifi)(double, uint64_t, double, uint64_t); +typedef double (win64_variant_f_fiff)(double, uint64_t, double, double); +typedef double (win64_variant_f_ffii)(double, double, uint64_t, uint64_t); +typedef double (win64_variant_f_ffif)(double, double, uint64_t, double); +typedef double (win64_variant_f_fffi)(double, double, double, uint64_t); +typedef double (win64_variant_f_ffff)(double, double, double, double); + +static Janet janet_ffi_win64(JanetFFISignature *signature, void *function_pointer, const Janet *argv) { + union { + uint64_t integer; + double real; + } regs[4]; + union { + uint64_t integer; + double real; + } ret_reg; + JanetFFIWordSpec ret_spec = signature->ret.spec; + void *ret_mem = &ret_reg.integer; + if (ret_spec == JANET_WIN64_STACK) { + ret_mem = alloca(type_size(signature->ret.type)); + regs[0].integer = (uint64_t) ret_mem; + } + uint64_t *stack = alloca(signature->stack_count * 8); + for (uint32_t i = 0; i < signature->arg_count; i++) { + int32_t n = i + 2; + JanetFFIMapping arg = signature->args[i]; + if (arg.spec == JANET_WIN64_STACK) { + janet_ffi_write_one(stack + arg.offset, argv, n, arg.type, JANET_FFI_MAX_RECUR); + } else if (arg.spec == JANET_WIN64_STACK_REF) { + uint8_t *ptr = (uint8_t *)(stack + args.offset2); + janet_ffi_write_one(ptr, argv, n, arg.type, JANET_FFI_MAX_RECUR); + stack[args.offset] = (uint64_t) ptr; + } else if (arg.spec == JANET_WIN64_REGISTER_REF) { + uint8_t *ptr = (uint8_t *)(stack + args.offset2); + janet_ffi_write_one(ptr, argv, n, arg.type, JANET_FFI_MAX_RECUR); + regs[args.offset].integer = (uint64_t) ptr; + } else { + janet_ffi_write_one((uint8_t *) ®s[arg.offset].integer, argv, n, arg.type, JANET_FFI_MAX_RECUR); + } + } + + /* the seasoned programmer who cut their teeth on assembly is probably quietly shaking their head by now... */ + switch (signature->variant) { + default: + janet_panic("unknown variant"); + case 0: + ret_reg.integer = ((win64_variant_i_iiii *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].integer, regs[3].integer); + break; + case 1: + ret_reg.integer = ((win64_variant_i_iiif *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].integer, regs[3].real); + break; + case 2: + ret_reg.integer = ((win64_variant_i_iifi *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].real, regs[3].integer); + break; + case 3: + ret_reg.integer = ((win64_variant_i_iiff *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].real, regs[3].real); + break; + case 4: + ret_reg.integer = ((win64_variant_i_ifii *) function_pointer)(regs[0].integer, regs[1].real, regs[2].integer, regs[3].integer); + break; + case 5: + ret_reg.integer = ((win64_variant_i_ifif *) function_pointer)(regs[0].integer, regs[1].real, regs[2].integer, regs[3].real); + break; + case 6: + ret_reg.integer = ((win64_variant_i_iffi *) function_pointer)(regs[0].integer, regs[1].real, regs[2].real, regs[3].integer); + break; + case 7: + ret_reg.integer = ((win64_variant_i_ifff *) function_pointer)(regs[0].integer, regs[1].real, regs[2].real, regs[3].real); + break; + case 8: + ret_reg.integer = ((win64_variant_i_fiii *) function_pointer)(regs[0].real, regs[1].integer, regs[2].integer, regs[3].integer); + break; + case 9: + ret_reg.integer = ((win64_variant_i_fiif *) function_pointer)(regs[0].real, regs[1].integer, regs[2].integer, regs[3].real); + break; + case 10: + ret_reg.integer = ((win64_variant_i_fifi *) function_pointer)(regs[0].real, regs[1].integer, regs[2].real, regs[3].integer); + break; + case 11: + ret_reg.integer = ((win64_variant_i_fiff *) function_pointer)(regs[0].real, regs[1].integer, regs[2].real, regs[3].real); + break; + case 12: + ret_reg.integer = ((win64_variant_i_ffii *) function_pointer)(regs[0].real, regs[1].real, regs[2].integer, regs[3].integer); + break; + case 13: + ret_reg.integer = ((win64_variant_i_ffif *) function_pointer)(regs[0].real, regs[1].real, regs[2].integer, regs[3].real); + break; + case 14: + ret_reg.integer = ((win64_variant_i_fffi *) function_pointer)(regs[0].real, regs[1].real, regs[2].real, regs[3].integer); + break; + case 15: + ret_reg.integer = ((win64_variant_i_ffff *) function_pointer)(regs[0].real, regs[1].real, regs[2].real, regs[3].real); + break; + case 16: + ret_reg.real = ((win64_variant_f_iiii *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].integer, regs[3].integer); + break; + case 17: + ret_reg.real = ((win64_variant_f_iiif *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].integer, regs[3].real); + break; + case 18: + ret_reg.real = ((win64_variant_f_iifi *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].real, regs[3].integer); + break; + case 19: + ret_reg.real = ((win64_variant_f_iiff *) function_pointer)(regs[0].integer, regs[1].integer, regs[2].real, regs[3].real); + break; + case 20: + ret_reg.real = ((win64_variant_f_ifii *) function_pointer)(regs[0].integer, regs[1].real, regs[2].integer, regs[3].integer); + break; + case 21: + ret_reg.real = ((win64_variant_f_ifif *) function_pointer)(regs[0].integer, regs[1].real, regs[2].integer, regs[3].real); + break; + case 22: + ret_reg.real = ((win64_variant_f_iffi *) function_pointer)(regs[0].integer, regs[1].real, regs[2].real, regs[3].integer); + break; + case 23: + ret_reg.real = ((win64_variant_f_ifff *) function_pointer)(regs[0].integer, regs[1].real, regs[2].real, regs[3].real); + break; + case 24: + ret_reg.real = ((win64_variant_f_fiii *) function_pointer)(regs[0].real, regs[1].integer, regs[2].integer, regs[3].integer); + break; + case 25: + ret_reg.real = ((win64_variant_f_fiif *) function_pointer)(regs[0].real, regs[1].integer, regs[2].integer, regs[3].real); + break; + case 26: + ret_reg.real = ((win64_variant_f_fifi *) function_pointer)(regs[0].real, regs[1].integer, regs[2].real, regs[3].integer); + break; + case 27: + ret_reg.real = ((win64_variant_f_fiff *) function_pointer)(regs[0].real, regs[1].integer, regs[2].real, regs[3].real); + break; + case 28: + ret_reg.real = ((win64_variant_f_ffii *) function_pointer)(regs[0].real, regs[1].real, regs[2].integer, regs[3].integer); + break; + case 29: + ret_reg.real = ((win64_variant_f_ffif *) function_pointer)(regs[0].real, regs[1].real, regs[2].integer, regs[3].real); + break; + case 30: + ret_reg.real = ((win64_variant_f_fffi *) function_pointer)(regs[0].real, regs[1].real, regs[2].real, regs[3].integer); + break; + case 31: + ret_reg.real = ((win64_variant_f_ffff *) function_pointer)(regs[0].real, regs[1].real, regs[2].real, regs[3].real); + break; + } + + return janet_ffi_read_one(ret_mem, signature->ret.type, JANET_FFI_MAX_RECUR); +} + +#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_arity(argc, 2, -1); + void *function_pointer = janet_getpointer(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: + janet_panic("calling convention not supported"); +#ifdef JANET_FFI_WIN64_ENABLED + case JANET_FFI_CC_WIN_64: + return janet_ffi_win64(signature, function_pointer, argv); +#endif +#ifdef JANET_FFI_SYSV64_ENABLED + case JANET_FFI_CC_SYSV_64: + return janet_ffi_sysv64(signature, function_pointer, argv); +#endif + } +} + +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 " + "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); + JanetFFIType type = decode_ffi_type(argv[0]); + size_t el_size = type_size(type); + JanetBuffer *buffer = janet_optbuffer(argv, argc, 2, el_size); + 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; + return janet_wrap_buffer(buffer); +} + +JANET_CORE_FN(cfun_ffi_buffer_read, + "(ffi/read ffi-type bytes &opt offset)", + "Parse a native struct out of a buffer and convert it to normal Janet data structures. " + "This function is the inverse of `ffi/write`. `bytes` can also be a raw pointer, although " + "this is unsafe.") { + janet_arity(argc, 2, 3); + JanetFFIType type = decode_ffi_type(argv[0]); + size_t offset = (size_t) janet_optnat(argv, argc, 2, 0); + if (janet_checktype(argv[1], JANET_POINTER)) { + uint8_t *ptr = janet_unwrap_pointer(argv[1]); + return janet_ffi_read_one(ptr + offset, type, JANET_FFI_MAX_RECUR); + } else { + size_t el_size = type_size(type); + JanetByteView bytes = janet_getbytes(argv, 1); + if ((size_t) bytes.len < offset + el_size) janet_panic("read out of range"); + return janet_ffi_read_one(bytes.bytes + offset, type, JANET_FFI_MAX_RECUR); + } +} + +JANET_CORE_FN(cfun_ffi_get_callback_trampoline, + "(ffi/trampoline cc)", + "Get a native function pointer that can be used as a callback and passed to C libraries. " + "This callback trampoline has the signature `void trampoline(void \\*ctx, void \\*userdata)` in " + "the given calling convention. This is the only function signature supported. " + "It is up to the programmer to ensure that the `userdata` argument contains a janet function " + "the will be called with one argument, `ctx` which is an opaque pointer. This pointer can " + "be further inspected with `ffi/read`.") { + janet_arity(argc, 0, 1); + JanetFFICallingConvention cc = JANET_FFI_CC_DEFAULT; + if (argc >= 1) cc = decode_ffi_cc(janet_getkeyword(argv, 0)); + switch (cc) { + default: + case JANET_FFI_CC_NONE: + janet_panic("calling convention not supported"); +#ifdef JANET_FFI_WIN64_ENABLED + case JANET_FFI_CC_WIN_64: + return janet_wrap_pointer(janet_ffi_win64_standard_callback); +#endif +#ifdef JANET_FFI_SYSV64_ENABLED + case JANET_FFI_CC_SYSV_64: + return janet_wrap_pointer(janet_ffi_sysv64_standard_callback); +#endif + } +} + +JANET_CORE_FN(janet_core_raw_native, + "(ffi/native &opt path)", + "Load a shared object or dll from the given path, and do not extract" + " or run any code from it. This is different than `native`, which will " + "run initialization code to get a module table. If `path` is nil, opens the current running binary. " + "Returns a `core/native`.") { + janet_arity(argc, 0, 1); + const char *path = janet_optcstring(argv, argc, 0, NULL); + char *processed_name = (NULL == path) ? NULL : get_processed_name(path); + Clib lib = load_clib(processed_name); + if (NULL != path && path != processed_name) janet_free(processed_name); + if (!lib) janet_panic(error_clib()); + JanetAbstractNative *anative = janet_abstract(&janet_native_type, sizeof(JanetAbstractNative)); + anative->clib = lib; + anative->closed = 0; + anative->is_self = path == NULL; + return janet_wrap_abstract(anative); +} + +JANET_CORE_FN(janet_core_native_lookup, + "(ffi/lookup native symbol-name)", + "Lookup a symbol from a native object. All symbol lookups will return a raw pointer " + "if the symbol is found, else nil.") { + janet_fixarity(argc, 2); + JanetAbstractNative *anative = janet_getabstract(argv, 0, &janet_native_type); + const char *sym = janet_getcstring(argv, 1); + if (anative->closed) janet_panic("native object already closed"); + void *value = symbol_clib(anative->clib, sym); + if (NULL == value) return janet_wrap_nil(); + return janet_wrap_pointer(value); +} + +JANET_CORE_FN(janet_core_native_close, + "(ffi/close native)", + "Free a native object. Dereferencing pointers to symbols in the object will have undefined " + "behavior after freeing.") { + janet_fixarity(argc, 1); + JanetAbstractNative *anative = janet_getabstract(argv, 0, &janet_native_type); + if (anative->closed) janet_panic("native object already closed"); + if (anative->is_self) janet_panic("cannot close self"); + anative->closed = 1; + free_clib(anative->clib); + return janet_wrap_nil(); +} + +void janet_lib_ffi(JanetTable *env) { + JanetRegExt ffi_cfuns[] = { + JANET_CORE_REG("ffi/native", janet_core_raw_native), + JANET_CORE_REG("ffi/lookup", janet_core_native_lookup), + JANET_CORE_REG("ffi/close", janet_core_native_close), + JANET_CORE_REG("ffi/signature", cfun_ffi_signature), + JANET_CORE_REG("ffi/call", cfun_ffi_call), + JANET_CORE_REG("ffi/struct", cfun_ffi_struct), + JANET_CORE_REG("ffi/write", cfun_ffi_buffer_write), + JANET_CORE_REG("ffi/read", cfun_ffi_buffer_read), + JANET_CORE_REG("ffi/size", cfun_ffi_size), + JANET_CORE_REG("ffi/align", cfun_ffi_align), + JANET_CORE_REG("ffi/trampoline", cfun_ffi_get_callback_trampoline), + JANET_REG_END + }; + janet_core_cfuns_ext(env, NULL, ffi_cfuns); +} + +#endif diff --git a/src/core/io.c b/src/core/io.c index 13721e5f..e05e7c01 100644 --- a/src/core/io.c +++ b/src/core/io.c @@ -545,6 +545,16 @@ static Janet cfun_io_printf_impl_x(int32_t argc, Janet *argv, int newline, if (newline) janet_buffer_push_u8(buf, '\n'); return janet_wrap_nil(); } + case JANET_FUNCTION: { + /* Special case function */ + JanetFunction *fun = janet_unwrap_function(x); + JanetBuffer *buf = janet_buffer(0); + janet_buffer_format(buf, fmt, offset, argc, argv); + if (newline) janet_buffer_push_u8(buf, '\n'); + Janet args[1] = { janet_wrap_buffer(buf) }; + janet_call(fun, 1, args); + return janet_wrap_nil(); + } case JANET_NIL: f = dflt_file; if (f == NULL) janet_panic("cannot print to nil"); @@ -684,6 +694,16 @@ void janet_dynprintf(const char *name, FILE *dflt_file, const char *format, ...) janet_buffer_deinit(&buffer); break; } + case JANET_FUNCTION: { + JanetFunction *fun = janet_unwrap_function(x); + int32_t len = 0; + while (format[len]) len++; + JanetBuffer *buf = janet_buffer(len); + janet_formatbv(buf, format, args); + Janet args[1] = { janet_wrap_buffer(buf) }; + janet_call(fun, 1, args); + break; + } case JANET_BUFFER: janet_formatbv(janet_unwrap_buffer(x), format, args); break; diff --git a/src/core/net.c b/src/core/net.c index 52293427..5f719841 100644 --- a/src/core/net.c +++ b/src/core/net.c @@ -884,7 +884,6 @@ static JanetStream *make_stream(JSock handle, uint32_t flags) { return janet_stream((JanetHandle) handle, flags | JANET_STREAM_SOCKET, net_stream_methods); } - void janet_lib_net(JanetTable *env) { JanetRegExt net_cfuns[] = { JANET_CORE_REG("net/address", cfun_net_sockaddr), diff --git a/src/core/os.c b/src/core/os.c index f443e14b..2660580d 100644 --- a/src/core/os.c +++ b/src/core/os.c @@ -39,6 +39,14 @@ #include #include +#ifdef JANET_BSD +#include +#endif + +#ifdef JANET_LINUX +#include +#endif + #ifdef JANET_WINDOWS #include #include @@ -201,6 +209,47 @@ JANET_CORE_FN(os_exit, return janet_wrap_nil(); } +JANET_CORE_FN(os_cpu_count, + "(os/cpu-count &opt dflt)", + "Get an approximate number of CPUs available on for this process to use. If " + "unable to get an approximation, will return a default value dflt.") { + janet_arity(argc, 0, 1); + Janet dflt = argc > 0 ? argv[0] : janet_wrap_nil(); +#ifdef JANET_WINDOWS + (void) dflt; + SYSTEM_INFO info; + GetSystemInfo(&info); + return janet_wrap_integer(info.dwNumberOfProcessors); +#elif defined(JANET_LINUX) + (void) dflt; + cpu_set_t cs; + CPU_ZERO(&cs); + sched_getaffinity(0, sizeof(cs), &cs); + int count = CPU_COUNT(&cs); + return janet_wrap_integer(count); +#elif defined(JANET_BSD) && defined(HW_NCPUONLINE) + (void) dflt; + const int name[2] = {CTL_HW, HW_NCPUONLINE}; + int result = 0; + size_t len = sizeof(int); + if (-1 == sysctl(name, 2, &result, &len, NULL, 0)) { + return dflt; + } + return janet_wrap_integer(result); +#elif defined(JANET_BSD) && defined(HW_NCPU) + (void) dflt; + const int name[2] = {CTL_HW, HW_NCPU}; + int result = 0; + size_t len = sizeof(int); + if (-1 == sysctl(name, 2, &result, &len, NULL, 0)) { + return dflt; + } + return janet_wrap_integer(result); +#else + return dflt; +#endif +} + #ifndef JANET_REDUCED_OS #ifndef JANET_NO_PROCESSES @@ -1296,6 +1345,7 @@ JANET_CORE_FN(os_date, if (argc >= 2 && janet_truthy(argv[1])) { /* local time */ #ifdef JANET_WINDOWS + _tzset(); localtime_s(&t_infos, &t); t_info = &t_infos; #else @@ -2195,6 +2245,7 @@ void janet_lib_os(JanetTable *env) { JANET_CORE_REG("os/chmod", os_chmod), JANET_CORE_REG("os/touch", os_touch), 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 diff --git a/src/core/pp.c b/src/core/pp.c index ff3f0c85..af28091e 100644 --- a/src/core/pp.c +++ b/src/core/pp.c @@ -762,8 +762,7 @@ static const char *scanformat( memset(precision, '\0', 3); while (*p != '\0' && strchr(FMT_FLAGS, *p) != NULL) p++; /* skip flags */ - if ((size_t)(p - strfrmt) >= sizeof(FMT_FLAGS) / sizeof(char)) - janet_panic("invalid format (repeated flags)"); + if ((size_t)(p - strfrmt) >= sizeof(FMT_FLAGS)) janet_panic("invalid format (repeated flags)"); if (isdigit((int)(*p))) width[0] = *p++; /* skip width */ if (isdigit((int)(*p))) @@ -983,8 +982,9 @@ void janet_buffer_format( break; } case 's': { - const uint8_t *s = janet_getstring(argv, arg); - int32_t l = janet_string_length(s); + JanetByteView bytes = janet_getbytes(argv, arg); + const uint8_t *s = bytes.bytes; + int32_t l = bytes.len; if (form[2] == '\0') janet_buffer_push_bytes(b, s, l); else { diff --git a/src/core/specials.c b/src/core/specials.c index 6a56ff9d..c608f8ab 100644 --- a/src/core/specials.c +++ b/src/core/specials.c @@ -31,7 +31,7 @@ static JanetSlot janetc_quote(JanetFopts opts, int32_t argn, const Janet *argv) { if (argn != 1) { - janetc_cerror(opts.compiler, "expected 1 argument"); + janetc_cerror(opts.compiler, "expected 1 argument to quote"); return janetc_cslot(janet_wrap_nil()); } return janetc_cslot(argv[0]); @@ -40,7 +40,7 @@ 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 (argn != 1) { - janetc_cerror(opts.compiler, "expected 1 argument"); + janetc_cerror(opts.compiler, "expected 1 argument to splice"); return janetc_cslot(janet_wrap_nil()); } ret = janetc_value(opts, argv[0]); @@ -117,7 +117,7 @@ static JanetSlot quasiquote(JanetFopts opts, Janet x, int depth, int level) { static JanetSlot janetc_quasiquote(JanetFopts opts, int32_t argn, const Janet *argv) { if (argn != 1) { - janetc_cerror(opts.compiler, "expected 1 argument"); + janetc_cerror(opts.compiler, "expected 1 argument to quasiquote"); return janetc_cslot(janet_wrap_nil()); } return quasiquote(opts, argv[0], JANET_RECURSION_GUARD, 0); @@ -143,7 +143,7 @@ static int destructure(JanetCompiler *c, JanetTable *attr) { switch (janet_type(left)) { default: - janetc_cerror(c, "unexpected type in destructuring"); + janetc_error(c, janet_formatc("unexpected type in destruction, got %v", left)); return 1; case JANET_SYMBOL: /* Leaf, assign right to left */ @@ -302,6 +302,9 @@ static JanetSlot janetc_varset(JanetFopts opts, int32_t argn, const Janet *argv) static JanetTable *handleattr(JanetCompiler *c, 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])) + : ""; for (i = 1; i < argn - 1; i++) { Janet attr = argv[i]; switch (janet_type(attr)) { @@ -309,7 +312,7 @@ static JanetTable *handleattr(JanetCompiler *c, int32_t argn, const Janet *argv) janetc_cerror(c, "unexpected form - did you intend to use defn?"); break; default: - janetc_cerror(c, "could not add metadata to binding"); + janetc_error(c, janet_formatc("cannot add metadata %v to binding %s", attr, binding_name)); break; case JANET_KEYWORD: janet_table_put(tab, attr, janet_wrap_true()); @@ -822,6 +825,7 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) { int selfref = 0; int seenamp = 0; int seenopt = 0; + int namedargs = 0; /* Begin function */ c->scope->flags |= JANET_SCOPE_CLOSURE; @@ -846,6 +850,9 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) { /* Keep track of destructured parameters */ JanetSlot *destructed_params = NULL; + JanetSlot *named_params = NULL; + JanetTable *named_table = NULL; + JanetSlot named_slot; /* Compile function parameters */ params = janet_unwrap_tuple(argv[parami]); @@ -853,49 +860,75 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) { arity = paramcount; for (i = 0; i < paramcount; i++) { Janet param = params[i]; - if (janet_checktype(param, JANET_SYMBOL)) { + if (namedargs) { + arity--; + if (!janet_checktype(param, JANET_SYMBOL)) { + errmsg = "only named arguments can follow &named"; + goto error; + } + Janet key = janet_wrap_keyword(janet_unwrap_symbol(param)); + janet_table_put(named_table, key, param); + janet_v_push(named_params, janetc_farslot(c)); + } else if (janet_checktype(param, JANET_SYMBOL)) { /* Check for varargs and unfixed arity */ - if (!janet_cstrcmp(janet_unwrap_symbol(param), "&")) { - if (seenamp) { - errmsg = "& in unexpected location"; - goto error; - } else if (i == paramcount - 1) { - allow_extra = 1; + const uint8_t *sym = janet_unwrap_symbol(param); + if (sym[0] == '&') { + if (!janet_cstrcmp(sym, "&")) { + if (seenamp) { + errmsg = "& in unexpected location"; + goto error; + } else if (i == paramcount - 1) { + allow_extra = 1; + arity--; + } else if (i == paramcount - 2) { + vararg = 1; + arity -= 2; + } else { + errmsg = "& in unexpected location"; + goto error; + } + seenamp = 1; + } else if (!janet_cstrcmp(sym, "&opt")) { + if (seenopt) { + errmsg = "only one &opt allowed"; + goto error; + } else if (i == paramcount - 1) { + errmsg = "&opt cannot be last item in parameter list"; + goto error; + } + min_arity = i; arity--; - } else if (i == paramcount - 2) { - vararg = 1; - arity -= 2; - } else { - errmsg = "& in unexpected location"; - goto error; - } - seenamp = 1; - } else if (!janet_cstrcmp(janet_unwrap_symbol(param), "&opt")) { - if (seenopt) { - errmsg = "only one &opt allowed"; - goto error; - } else if (i == paramcount - 1) { - errmsg = "&opt cannot be last item in parameter list"; - goto error; - } - min_arity = i; - arity--; - seenopt = 1; - } else if (!janet_cstrcmp(janet_unwrap_symbol(param), "&keys")) { - if (seenamp) { - errmsg = "&keys in unexpected location"; - goto error; - } else if (i == paramcount - 2) { + seenopt = 1; + } else if (!janet_cstrcmp(sym, "&keys")) { + if (seenamp) { + errmsg = "&keys in unexpected location"; + goto error; + } else if (i == paramcount - 2) { + vararg = 1; + structarg = 1; + arity -= 2; + } else { + errmsg = "&keys in unexpected location"; + goto error; + } + seenamp = 1; + } else if (!janet_cstrcmp(sym, "&named")) { + if (seenamp) { + errmsg = "&named in unexpected location"; + goto error; + } vararg = 1; structarg = 1; - arity -= 2; + arity--; + seenamp = 1; + namedargs = 1; + named_table = janet_table(10); + named_slot = janetc_farslot(c); } else { - errmsg = "&keys in unexpected location"; - goto error; + janetc_nameslot(c, sym, janetc_farslot(c)); } - seenamp = 1; } else { - janetc_nameslot(c, janet_unwrap_symbol(param), janetc_farslot(c)); + janetc_nameslot(c, sym, janetc_farslot(c)); } } else { janet_v_push(destructed_params, janetc_farslot(c)); @@ -914,6 +947,14 @@ static JanetSlot janetc_fn(JanetFopts opts, int32_t argn, const Janet *argv) { } janet_v_free(destructed_params); + /* Compile named arguments */ + if (namedargs) { + Janet param = janet_wrap_table(named_table); + destructure(c, param, named_slot, defleaf, NULL); + janetc_freeslot(c, named_slot); + janet_v_free(named_params); + } + max_arity = (vararg || allow_extra) ? INT32_MAX : arity; if (!seenopt) min_arity = arity; diff --git a/src/core/string.c b/src/core/string.c index e283ead0..632f7a50 100644 --- a/src/core/string.c +++ b/src/core/string.c @@ -530,7 +530,7 @@ JANET_CORE_FN(cfun_string_join, JANET_CORE_FN(cfun_string_format, "(string/format format & values)", - "Similar to `snprintf`, but specialized for operating with Janet values. Returns " + "Similar to C's `snprintf`, but specialized for operating with Janet values. Returns " "a new string.") { janet_arity(argc, 1, -1); JanetBuffer *buffer = janet_buffer(0); diff --git a/src/core/util.c b/src/core/util.c index e5126a6f..8670797b 100644 --- a/src/core/util.c +++ b/src/core/util.c @@ -739,6 +739,13 @@ int janet_checkint64(Janet x) { return janet_checkint64range(dval); } +int janet_checkuint64(Janet x) { + if (!janet_checktype(x, JANET_NUMBER)) + return 0; + double dval = janet_unwrap_number(x); + return dval >= 0 && dval <= JANET_INTMAX_DOUBLE && dval == (uint64_t) dval; +} + int janet_checksize(Janet x) { if (!janet_checktype(x, JANET_NUMBER)) return 0; @@ -877,6 +884,43 @@ int janet_cryptorand(uint8_t *out, size_t n) { #endif } +/* Dynamic library loading */ + +char *get_processed_name(const char *name) { + if (name[0] == '.') return (char *) name; + const char *c; + for (c = name; *c; c++) { + if (*c == '/') return (char *) name; + } + size_t l = (size_t)(c - name); + char *ret = janet_malloc(l + 3); + if (NULL == ret) { + JANET_OUT_OF_MEMORY; + } + ret[0] = '.'; + ret[1] = '/'; + memcpy(ret + 2, name, l + 1); + return ret; +} + +#if defined(JANET_WINDOWS) +static char error_clib_buf[256]; +char *error_clib(void) { + FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, GetLastError(), MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), + error_clib_buf, sizeof(error_clib_buf), NULL); + error_clib_buf[strlen(error_clib_buf) - 1] = '\0'; + return error_clib_buf; +} + +Clib load_clib(const char *name) { + if (name == NULL) { + return GetModuleHandle(NULL); + } else { + return LoadLibrary(name); + } +} +#endif /* Alloc function macro fills */ void *(janet_malloc)(size_t size) { diff --git a/src/core/util.h b/src/core/util.h index 9ff51f1a..7c6b195e 100644 --- a/src/core/util.h +++ b/src/core/util.h @@ -31,6 +31,14 @@ #include #include +#include +#include + +#ifdef JANET_EV +#ifndef JANET_WINDOWS +#include +#endif +#endif #if !defined(JANET_REDUCED_OS) || !defined(JANET_SINGLE_THREADED) #include @@ -121,6 +129,31 @@ int janet_gettime(struct timespec *spec); #define strdup(x) _strdup(x) #endif +/* Use LoadLibrary on windows or dlopen on posix to load dynamic libaries + * with native code. */ +#if defined(JANET_NO_DYNAMIC_MODULES) +typedef int Clib; +#define load_clib(name) ((void) name, 0) +#define symbol_clib(lib, sym) ((void) lib, (void) sym, NULL) +#define error_clib() "dynamic libraries not supported" +#define free_clib(c) ((void) (c), 0) +#elif defined(JANET_WINDOWS) +#include +typedef HINSTANCE Clib; +#define free_clib(c) FreeLibrary((c)) +#define symbol_clib(lib, sym) GetProcAddress((lib), (sym)) +Clib load_clib(const char *name); +char *error_clib(void); +#else +#include +typedef void *Clib; +#define load_clib(name) dlopen((name), RTLD_NOW) +#define free_clib(lib) dlclose((lib)) +#define symbol_clib(lib, sym) dlsym((lib), (sym)) +#define error_clib() dlerror() +#endif +char *get_processed_name(const char *name); + #define RETRY_EINTR(RC, CALL) do { (RC) = CALL; } while((RC) < 0 && errno == EINTR) /* Initialize builtin libraries */ @@ -159,5 +192,8 @@ void janet_lib_ev(JanetTable *env); void janet_ev_mark(void); int janet_make_pipe(JanetHandle handles[2], int mode); #endif +#ifdef JANET_FFI +void janet_lib_ffi(JanetTable *env); +#endif #endif diff --git a/src/core/vm.c b/src/core/vm.c index ae5f8de0..966d4941 100644 --- a/src/core/vm.c +++ b/src/core/vm.c @@ -220,14 +220,14 @@ /* Trace a function call */ static void vm_do_trace(JanetFunction *func, int32_t argc, const Janet *argv) { if (func->def->name) { - janet_printf("trace (%S", func->def->name); + janet_eprintf("trace (%S", func->def->name); } else { - janet_printf("trace (%p", janet_wrap_function(func)); + janet_eprintf("trace (%p", janet_wrap_function(func)); } for (int32_t i = 0; i < argc; i++) { - janet_printf(" %p", argv[i]); + janet_eprintf(" %p", argv[i]); } - janet_printf(")\n"); + janet_eprintf(")\n"); } /* Invoke a method once we have looked it up */ diff --git a/src/include/janet.h b/src/include/janet.h index 5952ed1b..08806300 100644 --- a/src/include/janet.h +++ b/src/include/janet.h @@ -163,6 +163,14 @@ extern "C" { #define JANET_DYNAMIC_MODULES #endif +/* Enable or disable the FFI library. Currently, FFI only enabled on + * x86-64, non-windows operating systems. */ +#ifndef JANET_NO_FFI +#if !defined(JANET_WINDOWS) && !defined(__EMSCRIPTEN__) && (defined(__x86_64__) || defined(_M_X64)) +#define JANET_FFI +#endif +#endif + /* Enable or disable the assembler. Enabled by default. */ #ifndef JANET_NO_ASSEMBLER #define JANET_ASSEMBLER @@ -299,10 +307,10 @@ typedef struct { JANET_CURRENT_CONFIG_BITS }) #endif -/* What to do when out of memory */ -#ifndef JANET_OUT_OF_MEMORY -#include -#define JANET_OUT_OF_MEMORY do { fprintf(stderr, "janet out of memory\n"); exit(1); } while (0) +/* Some extra includes if EV is enabled */ +#ifdef JANET_EV +typedef struct JanetOSMutex JanetOSMutex; +typedef struct JanetOSRWLock JanetOSRWLock; #endif /***** END SECTION CONFIG *****/ @@ -322,23 +330,10 @@ typedef struct { #include #include -/* Some extra includes if EV is enabled */ -#ifdef JANET_EV -#ifdef JANET_WINDOWS -typedef struct JanetDudCriticalSection { - /* Avoid including windows.h here - instead, create a structure of the same size */ - /* Needs to be same size as crtical section see WinNT.h for CRITCIAL_SECTION definition */ - void *debug_info; - long lock_count; - long recursion_count; - void *owning_thread; - void *lock_semaphore; - unsigned long spin_count; -} JanetOSMutex; -#else -#include -typedef pthread_mutex_t JanetOSMutex; -#endif + +/* 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) #endif #ifdef JANET_BSD @@ -849,6 +844,7 @@ JANET_API Janet janet_nanbox32_from_tagp(uint32_t tag, void *pointer); JANET_API int janet_checkint(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)) @@ -1180,17 +1176,6 @@ typedef struct { Janet payload; } JanetTryState; -/* Thread types */ -#ifdef JANET_THREADS -typedef struct JanetThread JanetThread; -typedef struct JanetMailbox JanetMailbox; -struct JanetThread { - JanetMailbox *mailbox; - JanetTable *encode; -}; -#endif - - /***** END SECTION TYPES *****/ /***** START SECTION OPCODES *****/ @@ -1379,11 +1364,19 @@ JANET_API void *janet_abstract_threaded(const JanetAbstractType *atype, size_t s JANET_API int32_t janet_abstract_incref(void *abst); JANET_API int32_t janet_abstract_decref(void *abst); -/* Expose some OS sync primitives to make portable abstract types easier to implement */ +/* Expose some OS sync primitives */ +JANET_API size_t janet_os_mutex_size(void); +JANET_API size_t janet_os_rwlock_size(void); JANET_API void janet_os_mutex_init(JanetOSMutex *mutex); JANET_API void janet_os_mutex_deinit(JanetOSMutex *mutex); JANET_API void janet_os_mutex_lock(JanetOSMutex *mutex); JANET_API void janet_os_mutex_unlock(JanetOSMutex *mutex); +JANET_API void janet_os_rwlock_init(JanetOSRWLock *rwlock); +JANET_API void janet_os_rwlock_deinit(JanetOSRWLock *rwlock); +JANET_API void janet_os_rwlock_rlock(JanetOSRWLock *rwlock); +JANET_API void janet_os_rwlock_wlock(JanetOSRWLock *rwlock); +JANET_API void janet_os_rwlock_runlock(JanetOSRWLock *rwlock); +JANET_API void janet_os_rwlock_wunlock(JanetOSRWLock *rwlock); /* Get last error from an IO operation */ JANET_API Janet janet_ev_lasterr(void); @@ -1925,6 +1918,7 @@ JANET_API void *janet_getpointer(const Janet *argv, int32_t n); JANET_API int32_t janet_getnat(const Janet *argv, int32_t n); JANET_API int32_t janet_getinteger(const Janet *argv, int32_t n); JANET_API int64_t janet_getinteger64(const Janet *argv, int32_t n); +JANET_API uint64_t janet_getuinteger64(const Janet *argv, int32_t n); JANET_API size_t janet_getsize(const Janet *argv, int32_t n); JANET_API JanetView janet_getindexed(const Janet *argv, int32_t n); JANET_API JanetByteView janet_getbytes(const Janet *argv, int32_t n); @@ -2078,16 +2072,6 @@ JANET_API int janet_scan_uint64(const uint8_t *str, int32_t len, uint64_t *out); #endif -#ifdef JANET_THREADS - -extern JANET_API const JanetAbstractType janet_thread_type; - -JANET_API int janet_thread_receive(Janet *msg_out, double timeout); -JANET_API int janet_thread_send(JanetThread *thread, Janet msg, double timeout); -JANET_API JanetThread *janet_thread_current(void); - -#endif - /* Custom allocator support */ JANET_API void *(janet_malloc)(size_t); JANET_API void *(janet_realloc)(void *, size_t); diff --git a/test/suite0009.janet b/test/suite0009.janet index 8a1ecc0d..018a7052 100644 --- a/test/suite0009.janet +++ b/test/suite0009.janet @@ -164,36 +164,26 @@ (:close s)) -(defn check-matching-names [stream] - (def ln (net/localname stream)) - (def pn (net/peername stream)) - (def [my-ip my-port] ln) - (def [remote-ip remote-port] pn) - (def msg (string my-ip " " my-port " " remote-ip " " remote-port)) - (def buf @"") - (ev/gather - (net/write stream msg) - (net/read stream 1024 buf)) - (def comparison (string/split " " buf)) - (assert (and (= my-ip (get comparison 2)) - (= (string my-port) (get comparison 3)) - (= remote-ip (get comparison 0)) - (= (string remote-port) (get comparison 1))) - (string/format "localname should match peername: msg=%j, buf=%j" msg buf))) - # Test on both server and client (defn names-handler [stream] (defer (:close stream) - (check-matching-names stream))) + # prevent immediate close + (ev/read stream 1) + (def [host port] (net/localname stream)) + (assert (= host "127.0.0.1") "localname host server") + (assert (= port 8000) "localname port server"))) # Test localname and peername -(repeat 20 +(repeat 10 (with [s (net/server "127.0.0.1" "8000" names-handler)] - (defn test-names [] + (repeat 10 (with [conn (net/connect "127.0.0.1" "8000")] - (check-matching-names conn))) - (repeat 20 (test-names))) + (def [host port] (net/peername conn)) + (assert (= host "127.0.0.1") "peername host client ") + (assert (= port 8000) "peername port client") + # let server close + (ev/write conn " ")))) (gccollect)) # Create pipe diff --git a/test/suite0011.janet b/test/suite0011.janet index 34dd6c34..171e9a16 100644 --- a/test/suite0011.janet +++ b/test/suite0011.janet @@ -1,4 +1,4 @@ -# Copyright (c) 2021 Calvin Rose & contributors +# Copyright (c) 2022 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 @@ -80,5 +80,18 @@ "table rawget regression" (table/new -1)) +# Named arguments +(defn named-arguments + [&named bob sally joe] + (+ bob sally joe)) + +(assert (= 15 (named-arguments :bob 3 :sally 5 :joe 7)) "named arguments 1") + +(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") + (end-suite) diff --git a/test/suite0012.janet b/test/suite0012.janet new file mode 100644 index 00000000..86b43eec --- /dev/null +++ b/test/suite0012.janet @@ -0,0 +1,54 @@ +# Copyright (c) 2022 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 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") + +(def has-ffi (dyn 'ffi/native)) + +# FFI check +(compwhen has-ffi + (ffi/context)) +(compwhen has-ffi + (ffi/defbind memcpy :ptr [dest :ptr src :ptr n :size])) +(compwhen has-ffi + (def buffer1 @"aaaa") + (def buffer2 @"bbbb") + (memcpy buffer1 buffer2 4) + (assert (= (string buffer1) "bbbb") "ffi 1 - memcpy")) + +(compwhen has-ffi + (assert (= 8 (ffi/size [:int :char])) "size unpacked struct 1") + (assert (= 5 (ffi/size [:pack :int :char])) "size packed struct 1") + (assert (= 5 (ffi/size [:int :pack-all :char])) "size packed struct 2") + (assert (= 4 (ffi/align [:int :char])) "align 1") + (assert (= 1 (ffi/align [:pack :int :char])) "align 2") + (assert (= 1 (ffi/align [:int :char :pack-all])) "align 3") + (assert (= 26 (ffi/size [:char :pack :int @[:char 21]])) "array struct size")) + +(end-suite) + diff --git a/test/suite0013.janet b/test/suite0013.janet new file mode 100644 index 00000000..1fd0bbdb --- /dev/null +++ b/test/suite0013.janet @@ -0,0 +1,30 @@ +# Copyright (c) 2022 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 13) + +(assert (deep= (tabseq [i :in (range 3)] i (* 3 i)) + @{0 0 1 3 2 6})) + +(assert (deep= (tabseq [i :in (range 3)] i) + @{})) + +(end-suite) diff --git a/tools/format.sh b/tools/format.sh old mode 100644 new mode 100755 diff --git a/tools/tm_lang_gen.janet b/tools/tm_lang_gen.janet index 9c0f6161..29c6292d 100644 --- a/tools/tm_lang_gen.janet +++ b/tools/tm_lang_gen.janet @@ -17,6 +17,7 @@ "quote" "quasiquote" "unquote" + "upscope" "splice"] (all-bindings))) (def allsyms (dyn :allsyms))