1
0
mirror of https://github.com/janet-lang/janet synced 2024-06-18 03:09:56 +00:00

Merge branch 'master' of github.com:janet-lang/janet

This commit is contained in:
bakpakin 2022-07-08 09:49:56 -05:00
commit 69853c8e5c
39 changed files with 2524 additions and 322 deletions

View File

@ -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: |

1
.gitattributes vendored
View File

@ -1,3 +1,4 @@
*.janet linguist-language=Janet
*.janet text eol=lf
*.c text eol=lf
*.h text eol=lf

View File

@ -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:

View File

@ -2,6 +2,9 @@ name: Test
on: [push, pull_request]
permissions:
contents: read
jobs:
test-posix:

View File

@ -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`.

View File

@ -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

View File

@ -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 \

View File

@ -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)
<img src="https://raw.githubusercontent.com/janet-lang/janet/master/assets/janet-w200.png" alt="Janet logo" width=200 align="left">
@ -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

45
examples/evlocks.janet Normal file
View File

@ -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)

71
examples/ffi/gtk.janet Normal file
View File

@ -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))

87
examples/ffi/so.c Normal file
View File

@ -0,0 +1,87 @@
#include <stdio.h>
#include <stdint.h>
#include <string.h>
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);
}

132
examples/ffi/test.janet Normal file
View File

@ -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.")

View File

@ -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

View File

@ -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)

View File

@ -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 :<anonymous> spath))}))
:source (or source (if path-is-file :<anonymous> 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 "<anonymous>") " [" (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"

View File

@ -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" */

View File

@ -23,14 +23,16 @@
#ifndef JANET_AMALG
#include "features.h"
#include <janet.h>
#include "util.h"
#include "gc.h"
#include "state.h"
#endif
#ifdef JANET_EV
#ifdef JANET_WINDOWS
#include <windows.h>
#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

View File

@ -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);

View File

@ -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) {

View File

@ -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 <windows.h>
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 <dlfcn.h>
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

View File

@ -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

View File

@ -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.

1241
src/core/ffi.c Normal file

File diff suppressed because it is too large Load Diff

View File

@ -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;

View File

@ -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),

View File

@ -39,6 +39,14 @@
#include <sys/stat.h>
#include <signal.h>
#ifdef JANET_BSD
#include <sys/sysctl.h>
#endif
#ifdef JANET_LINUX
#include <sched.h>
#endif
#ifdef JANET_WINDOWS
#include <windows.h>
#include <direct.h>
@ -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

View File

@ -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 {

View File

@ -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]))
: "<multiple bindings>";
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;

View File

@ -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);

View File

@ -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) {

View File

@ -31,6 +31,14 @@
#include <stdio.h>
#include <errno.h>
#include <stddef.h>
#include <stdbool.h>
#ifdef JANET_EV
#ifndef JANET_WINDOWS
#include <pthread.h>
#endif
#endif
#if !defined(JANET_REDUCED_OS) || !defined(JANET_SINGLE_THREADED)
#include <time.h>
@ -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 <windows.h>
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 <dlfcn.h>
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

View File

@ -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 */

View File

@ -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 <stdio.h>
#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 <stddef.h>
#include <stdio.h>
/* 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 <pthread.h>
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);

View File

@ -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

View File

@ -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)

54
test/suite0012.janet Normal file
View File

@ -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)

30
test/suite0013.janet Normal file
View File

@ -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)

0
tools/format.sh Normal file → Executable file
View File

View File

@ -17,6 +17,7 @@
"quote"
"quasiquote"
"unquote"
"upscope"
"splice"]
(all-bindings)))
(def allsyms (dyn :allsyms))